excel - VBA:将 2 列或更多列中的值复制到具有相应行的一列中

Question

我对 VBA 很陌生，想执行以下操作，但不确定如何:
首先，我用逗号分隔数据。 (这个很好，因为我也可以使用记录宏选项来做到这一点)
问题是我还想将信息从每一行转换为一列，行在另一行之下。但是，我还想在数据分隔之前将相应的行添加到数据中。这是一个例子:
Example

Answer 1

Unpivot '逗号' 分隔
样本数据

Country;Fruits
France;Apple,Oranges
Germany;Oranges,Bananas
UK;Grapes,Lemons
Sweden;Mandarines,Strawberries,Bananas, Apples

创建 (OP)

=IF(A1="","",A1&";"&B1)

复制 (CTRL+C) 范围并粘贴 (CTRL+V) 到 NotePad .

选择 All和 Copy (CTRL+A, CTRL+C)

在此处粘贴 (CTRL+V)。

选择整个文本并单击代码示例图标 ({}) 或使用 CTRL+K。

使用(用户)

选择文本并复制 (CTRL+C)，

Right-click第一个单元格 ( A1 ) 和 Paste ( Match Destination Formatting ),

Data > TextToColumns ,

Next ,

Delimiter :查看Semicolon

Finish

程序
用途/特点

注意 :如果您使用相同的工作表和相同的第一个单元格地址，您将被覆盖。
注意没有Undo .

调整四个常数的值。

打开立即窗口 (CTRL+G) 以查看各个阶段的范围地址。

Application.Trim将覆盖任何多余的空间，如瑞典苹果中的空间。

代码

Option Explicit

Sub unpivotCommaSeparated()
    
    Const sName As String = "Sheet1"
    Const sFirst As String = "A1"
    
    Const dName As String = "Sheet1"
    Const dFirst As String = "D1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sData As Variant
    Dim rg As Range
    Dim isDataInArray As Boolean
    
    With wb.Worksheets(sName).Range(sFirst)
        Debug.Print "Source First Cell:                " & .Address(0, 0)
        Set rg = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If Not rg Is Nothing Then
            Debug.Print "Source Last Cell in First Column: " & rg.Address(0, 0)
            Set rg = .Resize(rg.Row - .Row + 1, 2)
            Debug.Print "Source Range:                     " & rg.Address(0, 0)
            sData = rg.Value
            isDataInArray = True
        End If
    
    End With
    
    If isDataInArray Then
        
        Dim srCount As Long: srCount = UBound(sData, 1)
        Dim cCount As Long: cCount = UBound(sData, 2)
        ReDim Preserve sData(1 To srCount, 1 To cCount + 1)
        
        Dim drCount As Long: drCount = 1
        Dim i As Long
        
        For i = 2 To srCount
            sData(i, 2) = Split(sData(i, 2), ",")
            sData(i, 3) = UBound(sData(i, 2))
            drCount = drCount + sData(i, 3) + 1
        Next i
        
        Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
        Dim j As Long
        
        For j = 1 To cCount
            dData(1, j) = sData(1, j)
        Next j
            
        Dim k As Long: k = 1
        
        For i = 2 To srCount
            For j = 0 To sData(i, 3)
                k = k + 1
                dData(k, 1) = sData(i, 1)
                dData(k, 2) = Application.Trim(sData(i, 2)(j))
            Next j
        Next i
    
        With wb.Worksheets(dName).Range(dFirst).Resize(, cCount)
            Debug.Print "Destination First Row Range:      " & .Address(0, 0)
            Set rg = .Resize(k)
            Debug.Print "Destination Range:                " & rg.Address(0, 0)
            rg.Value = dData
            Set rg = .Resize(.Worksheet.Rows.Count - .Row - k + 1).Offset(k)
            Debug.Print "Clear Range:                      " & rg.Address(0, 0)
            rg.ClearContents
        End With
    
    End If
    
End Sub