（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

这是你追求的结果吗？

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

---

之前

之后

Answer 2

试试这个代码。输入范围是从 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文件并逐步运行代码以理解它