Question

我正在尝试对动态调整范围的动态数量执行一些操作。每次运行该程序时，不连续范围的数量以及范围的大小都可能改变。我通过在A列（下划线）中找到定界符来确定自己的范围。现在，VBA会将下面的范围识别为两个不同的区域，但是在被调用以查找包含定界符的字符串时同时选择了两个范围，这是正确的。我将范围区域从一页转移到下一页。在每个范围的第一列（列A）中，都有一个名称，而该行的其余部分包含各种数字。在每个范围中，字符串名称各不相同，但是它们都与其他范围中的字符串名称相对应。例如，每个范围中的所有第一个字符串名称都以_1结尾。对于每个范围，范围内的第二个字符串名称（或第一个字符串下方的行中的单元格）以_2结尾。下面是一张图片：

我知道我可以删除每个范围之间的空白行，但是我认为这不是我想要的输出的最佳解决方案。我想获取第一个区域的第一行（在此示例中为A5：E5），将其转置，然后将其粘贴到（在此示例中）B5：B9的新表中。然后，我想转到下一个区域并执行相同的操作（因此，复制A9：E9），进行转置，然后将其粘贴到下一列中的同一张纸上（因此，C5：C9）。然后，我想回到我的第一个范围，并移至下一行（A6：E6），将其转置并粘贴到D5：D9，然后移至下一个区域并取（A10：E10），依此类推直到所有范围都已粘贴到新页面上。因此，理想情况下，我想在范围之间切换，并将每一行连续地粘贴到一列中。这是我想要的输出：

我很难按自己想要的方式获取数据，并且知道我可能无法选择在范围之间进行切换，因此我愿意听取任何想法。同样，范围（或区域）的数量可以随每次运行而改变，范围的大小也可以改变。在此示例中，我有两个具有3个字符串名称的范围，但是在下一轮中，我可以有3个具有4个字符串名称的范围，所以我不能硬编码任何东西。字符串名称并不总是相同的（input_x，output_x），因此我也不能对它们进行硬编码，但是我可以搜索定界符（字符串名称中的下划线），因为它将始终格式化为字符串名称。

我当前的输出确实会复制并粘贴该区域中的每个单元格，但这是我尝试过的最好的方法：

这是我的代码（评论是我一直在尝试的一些事情）：

Dim myRange as Range
Dim c as Range, a as Range
Dim t As Long, m as Long
Dim delimiterItem as Variant
Dim newSheetName as String

newSheetName = ActiveSheet.Name
delimiterItem = "_"
t = 2

    With Sheets.Add(After:=Sheets(Sheets.Count))
        .Name = "Final"


        If myRange Is Nothing Then
            MsgBox ("Value not present in this workbook.")
        Else
            For Each a In myRange.Areas

                For Each c In a.Rows
                    Worksheets(newSheetName).Activate
                    c.EntireRow.Copy
                    'For m = Cells(myRange.Rows.Count, 1).End(xlUp).Row To 2 Step -1
                    'If Split(InStrRev(myRange.Cells(m, 1).Text, delimiterItem))(0) = Split(InStrRev(myRange.Cells(m - 1, 1).Text, delimiterItem))(0) Then

                    Worksheets("Final").Activate
                    Cells(8, t).Select
                    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                          False, Transpose:=True

                    t = t + 1
                    'Sheets("Final").Range("B8").Offset(0, (t - 2) * 2).PasteSpecial xlPasteValues
                Next c
             Next a
        End If
    End With

任何帮助或指向正确方向的指针将不胜感激。谢谢！很抱歉，这个问题的长度。

Answer 1

这里是一个替代示例，该示例使用memory-based arrays来提高速度，并有助于数据的转置和正确调整大小。

此算法假定：

您将始终拥有以_1开头的数据集
数据集编号始终按顺序增加，例如_1，_2，_3等
总是有与数据集相同数量的数据“组”。

我的样本数据如下：

首先，我将数据移动到基于内存的数组中

Dim inData As Variant
inData = Sheet1.UsedRange.Value

然后基于这些假设，为了正确地对结果进行排序，您需要计算出您拥有多少个数据集。因此，我创建了一个利用Split函数的函数来获取下划线后面的数字值：

Private Function DetermineNumberOfSets(ByRef data As Variant) As Long
    '--- runs through the labels in the first column and separates
    '    the number value following the underscore to find the maximum
    '    count of data sets
    Dim max As Long
    Dim i As Long
    For i = LBound(data, 1) To UBound(data, 1)
        Dim tokens As Variant
        tokens = Split(data(i, 1), "_")
        If UBound(tokens) > 0 Then
            If max < tokens(1) Then max = tokens(1)
        End If
    Next i
    DetermineNumberOfSets = max
End Function

所以主例程会调用

Dim dataSetCount As Long
Dim columnCount As Long
dataSetCount = DetermineNumberOfSets(inData)

'--- this determines how many columns are in the output data
Dim allSetsCount As Long
allSetsCount = dataSetCount * dataSetCount

通过以这种方式计算allSetsCount，可以有效地跳过输入数据中的任何空白行。

现在创建一个数组来保存所有转置的数据

'--- this determines how many rows are in the output data
Dim maxDataPointsCount As Long
maxDataPointsCount = UBound(inData, 2)

Dim outData As Variant
ReDim outData(1 To maxDataPointsCount, 1 To allSetsCount)

最后遍历数据以按顺序收集数据集并将数据转置到输出数组。

Dim setNumber As Long
For setNumber = 1 To dataSetCount
    '--- run through the data and pick out the data for this set
    Dim i As Long
    For i = LBound(inData, 1) To UBound(inData, 1)
        Dim thisSetNumber As Long
        thisSetNumber = WhatsTheDataSet(inData(i, 1))
        If thisSetNumber = setNumber Then
            '--- copy this set to the output
            Dim j As Long
            For j = 1 To maxDataPointsCount
                outData(j, outputColumn) = inData(i, j)
            Next j
            outputColumn = outputColumn + 1
        End If
    Next i
Next setNumber

这是所有代码的整个模块

Option Explicit
Option Base 0

Public Sub CollateData()
    Dim inData As Variant
    inData = Sheet1.UsedRange.Value

    Dim dataSetCount As Long
    Dim columnCount As Long
    dataSetCount = DetermineNumberOfSets(inData)

    '--- this determines how many columns are in the output data
    Dim allSetsCount As Long
    allSetsCount = dataSetCount * dataSetCount

    '--- this determines how many rows are in the output data
    Dim maxDataPointsCount As Long
    maxDataPointsCount = UBound(inData, 2)

    Dim outData As Variant
    ReDim outData(1 To maxDataPointsCount, 1 To allSetsCount)

    Dim outputColumn As Long
    outputColumn = 1

    Dim setNumber As Long
    For setNumber = 1 To dataSetCount
        '--- run through the data and pick out the data for this set
        Dim i As Long
        For i = LBound(inData, 1) To UBound(inData, 1)
            Dim thisSetNumber As Long
            thisSetNumber = WhatsTheDataSet(inData(i, 1))
            If thisSetNumber = setNumber Then
                '--- copy this set to the output
                Dim j As Long
                For j = 1 To maxDataPointsCount
                    outData(j, outputColumn) = inData(i, j)
                Next j
                outputColumn = outputColumn + 1
            End If
        Next i
    Next setNumber

    Dim outRange As Range
    Set outRange = Sheet2.Range("A1").Resize(UBound(outData, 1), UBound(outData, 2))
    outRange.Value = outData

End Sub

Private Function DetermineNumberOfSets(ByRef data As Variant) As Long
    '--- runs through the labels in the first column and separates
    '    the number value following the underscore to find the maximum
    '    count of data sets
    Dim max As Long
    Dim i As Long
    For i = LBound(data, 1) To UBound(data, 1)
        Dim tokens As Variant
        tokens = Split(data(i, 1), "_")
        If UBound(tokens) > 0 Then
            If max < tokens(1) Then max = tokens(1)
        End If
    Next i
    DetermineNumberOfSets = max
End Function

Private Function WhatsTheDataSet(ByVal label As String) As Long
    Dim tokens As Variant
    tokens = Split(label, "_")
    If UBound(tokens) > 0 Then
        WhatsTheDataSet = tokens(1)
    End If
End Function

Answer 2

请尝试使用此代码。它仅在内存中工作并且非常快。我将尝试解释某些行（可能看起来很奇怪）的作用。无论A：A列中的字符串的任何（“ _”）字符，它都有效。这是起始页（“区域”）：这是结果（“最终”）表：子测试TransposeMyAreas（）昏暗的工作表，rngUR的范围，j长，ii长调光作为范围，使用R作为范围，rA作为范围，arVal作为变量昏暗的shFin作为工作表，k长，i长，ArTr（）作为变体

  Set sh = ActiveWorkbook.Worksheets("Areas") ' obviously the sheet keeping areas to be transposed
    If Sheets(Sheets.count).Name = "Final" Then
        Set shFin = ActiveWorkbook.Worksheets("Final")
        shFin.UsedRange.Clear' for testing reason only
    Else
        Set shFin = Sheets.Add(After:=Sheets(Sheets.count))
        shFin.Name = "Final"
    End If

  Set rngUR = sh.UsedRange

  'define all the (really used range) of the worksheet:
  Set usedR = sh.Range(rngUR.Cells(1, 1).Address & ":" & _
        rngUR.Cells(rngUR.Rows.count, rngUR.Columns.count).Address)

  'tricky way to separtate the areas...
  Set rng = usedR.SpecialCells(xlCellTypeConstants)

  k = 0      
  For Each rA In rng.Areas
    ReDim ArTr(rA.Columns.count) 'redim the array used to transfer data to the "Final" one
    arVal = rA.Value 'load the area range in ArVal array

     For i = 1 To rA.Rows.count
        For ii = 0 To rA.Columns.count - 1
            ArTr(ii) = arVal(i, ii + 1) 'fill the transfer array (diferently for each area row)
        Next ii
            'create the paste range and make the transfer:
            'to optimize the code, it does what you explain, but not in that suggested order
            'I mean, it firstly fill column B:B, then the column situated at how manu areas exists (once for each iteration)
            shFin.Range(Cells(5, 2 + k + j).Address & ":" & Cells(rA.Columns.count + 4, 2 + k + j).Address).Value = _
                                                    Application.WorksheetFunction.Transpose(ArTr) ': Stop
            k = i * rng.Areas.count ' used to define position of the next column to be filled
    Next i
    j = j + 1: k = 0
  Next
End Sub

如果不清楚，请随时澄清。

此代码从一个区域中所有行和列的数目均相等的假设开始。

为了更好地了解它是如何工作的，我建议在Stop之后取消注释...Transpose(ArTr)命令，使VBE窗口变小并查看工作表上正在发生什么，在每次操作后按F5停止。

如何区分非连续范围？

2 个答案: