Question

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

    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

Answer 1

尝试对此进行调整。

Sub x()

Dim r As Range
application.screenupdating=false
For Each r In Sheet1.Columns(1).SpecialCells(xlCellTypeConstants).Areas
    r.Copy
    Sheet2.Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial Transpose:=True
    'Sheet2.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial Transpose:=True
Next r
application.screenupdating=true    
End Sub

Answer 2

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

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

编辑：根据OP的要求，该过程正常运行时添加了On Error Resume Next，即使数据行之间有多个空白。在这种情况下，On Error Resume Next避免了与Range.Resize属性关联的Run-time error '1004' Application-defined or Object Defined Error。当if语句查看出现的空白单元格大于1时，将引发错误。在该语句的else部分中，counter变量将等于0，从而导致范围的第二维为0并抛出错误。如果OP所建议的那样，如果A列中的单元格确实为空白，则这是捕获错误的有效方法。还添加了Trim()函数来处理可能包含空格的空白单元格。

VBA根据空行转置数据

2 个答案: