VBA根据空行转置数据 [英] VBA to transpose data based on empty lines

问题描述

我在excel中有一个EXTREMELY大型数据集，数据集各不相同(有些具有12行，有些具有18行，等等)，这些数据集目前位于需要转置为列的行中.所有分组均由空行/空白行分隔.我启动了VBA来转置它，但不知道如何包含/查看空白行并将其循环到每张纸的末尾.有什么想法/建议吗?

I have an EXTREMELY large data set in excel with varying data sets (some have 12 lines and some with 18, etc) that are currently in rows that needs to be transposed to columns. All the groupings are separated by a empty/blank line. I started the VBA to transpose this it but dont know how to include/look at the blank line and loop it to the end of each sheet. Any ideas/suggestions?

    Range("F1:F12").Select
Selection.Copy
Sheets("Sheet4").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
Sheets("Sheet3").Select
Range("F14:F27").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
Range("G14").Select

推荐答案

不惜一切代价避免使用 Select 语句，并尽可能使用 Array 数据结构来处理数据.处理 Arrays 中的数据比从工作表中读取/写入要快得多.下面的过程应做您想要的.请注意，尽管在循环中使用 ReDim Preserve 不是理想的，但是，我已经将它用于超过100,000行的计数，没有问题.要点是，13,000行应该没问题.

Avoid using Select statements at all costs and when possible, use the Array data structure to process data. Processing data in Arrays is much faster than reading/writing from the worksheet. The Procedure below should do what you want. Note that although it's not ideal to use ReDim Preserve in a loop, however, I have used it for row counts of over 100,000 with no issue. Point being, 13,000 rows should be no problem.

Sub Transpose()
 Dim Data_Array
 Dim OutPut_Array()
 Dim LR As Long, Counter As Long, LR2 As Long
 Dim i As Long

 Application.ScreenUpdating = False

  'Find the last row of your data in Sheet3 Column A 
  'I added 1 so that the conditional statement below 
  'doesn't exclude the last row of data
  With Sheets("Sheet3")
     LR = .Cells(Rows.Count, "A").End(xlUp).Row + 1
     Data_Array = .Range("A1:A" & LR).Value2
  End With 

    'See explanation in the edit section below 
    On Error Resume Next 
    For i = LBound(Data_Array, 1) To UBound(Data_Array, 1)

        'if the cell is not blank then increase the counter by one
        'and for each non blank cell in the Data_Array, 
        'add it to the OutPut_Array
        'If its not blank then output the prepopulated OutPut_Array to Sheet4 and 
        'set the counter back to zero 
        If Trim(Data_Array(i, 1)) <> vbNullString Then
            Counter = Counter + 1

            ReDim Preserve OutPut_Array(1 To 1, 1 To Counter)

            OutPut_Array(1, Counter) = Data_Array(i, 1)

        Else

            With Sheets("Sheet4")
                LR2 = .Cells(Rows.Count, "A").End(xlUp).Row
                .Range("A" & LR2 + 1).Resize(1, Counter).Value2 = OutPut_Array
            End With

            Counter = 0
        End If
    Next i

End Sub

测试数据:

结果:

这也可以用 nested字典完成，但是在这种情况下，需要使用数组来辅助它使用条件语句创建一对多关系，然后转置字典，但是我我仍在尝试完善该方法，所以我接受了以上内容，哈哈.希望这会有所帮助.

This could also be done with a nested dictionary however in this case it would need to be assisted by array to create a one to many relationship using conditional statements, and then transposing the dictionary, but I am still trying to perfect that method so I went with the above, lol. Hope this is helpful.

根据OP对程序运行的要求，添加了 Next Error Resume Next ，即使数据行之间有多个空白，也是如此.在这种情况下， On Error Resume Next 避免了与Range.Resize属性关联的运行时错误'1004'应用程序定义的错误或对象定义的错误.当if语句查看出现的空白单元格大于1时，将引发错误.在该语句的else部分中，counter变量将等于0，从而导致范围的第二维为0并抛出错误.如果OP所建议的话，如果A列中的单元格真正是空白的，那么这是捕获错误的有效方法.还添加了 Trim()函数来处理可能有空格的空白单元格.

Added On Error Resume Next as per OP's request for the procedure to work even if there is more than one blank between the rows of data. In this case On Error Resume Next avoids the Run-time error '1004' Application-defined or Object Defined Error associated with the Range.Resize property. The error is thrown when the if statement is looking at occurences of a blank cells greater than 1. In the else portion of the statement, the counter variable would be equal to 0, thus causing the second dimension of the range to be 0 and throwing the error. If the cells in column A are truly blank as the OP suggests, then this is a valid method to trap the error. Also added the Trim() function to handle blank cells that may have spaces.

这篇关于VBA根据空行转置数据的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！