（VBA）具有數千行的Excel-如何將可變長度列轉置為行？

Question

我有一個Excel工作表，正在處理9948行。 一個單元格中將包含多條信息，因此到目前為止，我所做的是通過Excel的“文本到列”功能對這些信息進行定界。

（所有數據和列標題都是任意的）

它開始像這樣：

 ID | Name |           Property1          |
 1    Apple     JO18, GFBAJH, HFDH, 78EA

它在前幾列中具有數據（采用文本/數字混合格式），該數據實際上應位於其自己的行上。 這些屬性之一的屬性數量各不相同，因此一個屬性可能具有五個屬性，另一個屬性可能具有20個屬性。在分隔行之后，它看起來像這樣：

 ID | Name | Property1| Property2 | Property3 | Property4 | Property5 | Property6 |
 1    Apple    J012       B83A        G5DD      
 2    Banana   RETB       7CCV
 3    Orange   QWER       TY          YUIP      CVBA        UBBN         FDRT
 4    Pear     55V        DWZA        6FJE      LKOI        PAKD
 5    Cherry   EEF        AGC         TROU

我一直試圖實現的目標是使其看起來像這樣：

    ID | Name | Property1| Property2 | Property3 | Property4 | Property5 | Property6 |
 1      Apple    J012       
                 B83A        
                 G5DD      
 2      Banana   RETB       
                 7CCV
 3      Orange   QWER       
                 TY          
                 YUIP      
                 CVBA        
                 UBBN         
                 FDRT
 4      Pear     55V        
                 DWZA        
                 6FJE      
                 LKOI        
                 PAKD
 5      Cherry   EEF        
                 AGC         
                 TROU   

我已經能夠手動進行檢查並轉置每一行的數據，這導致了超過33,000行。 這非常耗時，我毫不懷疑我在這里和那里都犯了一些錯誤，因此我想探索一種自動化的方法。

我已經探索了通過復制行，將其粘貼在底部，復制其他屬性並將其移到Property1下來記錄宏的方法，但是每次我嘗試重復此操作時，它只會粘貼到同一行，而沒有行的可變大小長度。 我在試圖將其遞增1的宏中將其注釋掉，但它給出了“類型不匹配”錯誤

錄制的宏：

Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+Shift+A
'
   Selection.Copy
   ActiveWindow.ScrollRow = 9922
   ActiveWindow.SmallScroll Down:=3
   'Range("A9948").Value = Range("A9948").Value + 1
   Range("A9948").Select
   ActiveSheet.Paste
   ActiveWindow.SmallScroll Down:=6
   Range("E9948:Z9948").Select
   Application.CutCopyMode = False
   Selection.Copy
   Range("D9949").Select
   Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=  _
        False, Transpose:=True
End Sub

任何幫助，將不勝感激。

Answer 1

試試這個代碼。 輸入范圍是從Apple到Cherry的第一列。

Set Rng = Sheets("sheet1").Range("B2:B6")   'Input range of all fruits
Set Rng_output = Sheets("sheet2").Range("B2")   'Output range

For i = 1 To Rng.Cells.Count
    Set rng_values = Range(Rng.Cells(i).Offset(0, 1), Rng.Cells(i).End(xlToRight)) 'For each fruit taking the values to the right which need to be transposed

    If rng_values.Cells.Count < 16000 Then 'To ensure that it doesnt select till the right end of the sheet
        For j = 1 To rng_values.Cells.Count
                Rng_output.Value = Rng.Cells(i).Value
                Rng_output.Offset(0, 1).Value = rng_values.Cells(j).Value
                Set Rng_output = Rng_output.Offset(1, 0)  'Shifting the output row so that next value can be printed
        Next j
    End If
Next i

使用輸入中顯示的數據創建一個excel文件，並逐步運行代碼以理解它

Answer 2

這是您追求的結果嗎？

Option Explicit

Public Sub TransposeRows()
    Dim i As Long, j As Long, k As Long, ur As Variant, tr As Variant
    Dim thisVal As String, urMaxX As Long, urMaxY As Long, maxY As Long

    With Sheet1
        ur = .UsedRange
        urMaxX = UBound(ur, 1)
        urMaxY = UBound(ur, 2)
        maxY = urMaxX * urMaxY
        ReDim tr(2 To maxY, 1 To 3)
        k = 2
        For i = 2 To urMaxX
            For j = 2 To urMaxY
                thisVal = Trim(ur(i, j))
                If Len(thisVal) > 0 Then
                    If j = 2 Then
                        tr(k, 1) = Trim(ur(i, 1))
                        tr(k, 2) = Trim(ur(i, 2))
                        tr(k, 3) = Trim(ur(i, 3))
                        j = j + 1
                    Else
                        tr(k, 3) = thisVal
                    End If
                    k = k + 1
                Else
                    Exit For
                End If
            Next
        Next
        .UsedRange.Offset(1).Clear
        .Range(.Cells(2, 1), .Cells(maxY, 3)) = tr
    End With
End Sub

---

之前

后