VBA to transpose data based on empty lines

问题

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

回答1:

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

Test Data:

Result:

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.

Edit: 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.

回答2:

Try adapting this.

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

来源：https://stackoverflow.com/questions/54426859/vba-to-transpose-data-based-on-empty-lines