从范围复制行并拆分单元格值

使用分隔字符串对列进行逆透视

• 调整常量部分中的值。

代码

Option Explicit

Sub uvpivotSeparated()
    
    ' source
    Const sName As String = "Sheet1"
    Const sFirst As String = "A1"
    Const sepCol As Long = 3
    ' DesTination
    Const dName As String = "Sheet2"
    Const dFirst As String = "A1"
    ' Other
    Const Delimiter As String = "; "
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Define source Range.
    Dim rg As Range: Set rg = wb.Worksheets(sName).Range(sFirst)
    With rg.CurrentRegion
        Set rg = rg.Resize(.Row + .Rows.Count - rg.Row,_
            .column + .columns.Count - rg.column)
    End With
    
    ' Write values from source Range to Data Array.
    Dim Data As Variant: Data = rg.Value
    Dim srCount As Long: srCount = UBound(Data,1)
    Dim dcCount As Long: dcCount = UBound(Data,2)
    Dim scCount As Long: scCount = dcCount + 1
    
    ' Add a column to Data Array.
    ReDim Preserve Data(1 To srCount,1 To scCount)
    
    ' Calculate Result Array Rows Count,replace each separated value
    ' with an array,and write its upper bound to the extra column.
    Dim drCount As Long: drCount = 1 ' headers
    Dim i As Long
    For i = 2 To srCount
        Data(i,sepCol) = Split(Data(i,sepCol),Delimiter)
        Data(i,scCount) = UBound(Data(i,sepCol))
        drCount = drCount + Data(i,scCount) + 1
    Next i
    
    ' Define Result Array.
    Dim Result As Variant: ReDim Result(1 To drCount,1 To dcCount)
    ' Write headers.
    Dim j As Long
    For j = 1 To dcCount
        Result(1,j) = Data(1,j)
    Next j
    ' Write body.
    Dim k As Long: k = 1 ' headers
    Dim n As Long
    For i = 2 To srCount
        For n = 0 To Data(i,scCount)
            k = k + 1
            For j = 1 To dcCount
                If j <> sepCol Then
                    Result(k,j) = Data(i,j)
                End If
            Next j
            Result(k,sepCol) = Data(i,sepCol)(n)
         Next n
    Next i
    
    ' Write values from Result Array to DesTination Range.
    With wb.Worksheets(dName).Range(dFirst).Resize(,dcCount)
        .Resize(drCount).Value = Result
        ' Clear contents below.
        '.Resize(.Worksheet.Rows.Count - drCount - .Row + 1) _
            .offset(drCount).ClearContents
    End With
    
End Sub