excel - 如何在 Excel VBA 中将单行列分解为多行

Question

我有一组看起来像这样的数据。

源结构

但我想将项目列复制到另一张纸上的单独行中。在这种情况下，源工作表中的每一行都会在目标工作表中生成四行，因为有四个项目。

这是所需目标数据结构的图片。

目标数据结构

此数据将定期更改，新条目将添加到源底部。我已经弄清楚了如何遍历一系列数据，但不知道如何选择单个单元格以在下一张纸上书写。我是 VBA 新手，所以任何帮助将不胜感激。

Answer 1

您需要将 wsSource 和 wsTarget 的名称更改为它们的实际工作表名称：

Sub tgr()

    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim arrSource() As Variant
    Dim arrData() As Variant
    Dim rIndex As Long
    Dim cIndex As Long
    Dim DataIndex As Long
    Dim lNumProjects As Long

    Set wsSource = Sheets("Source")
    Set wsTarget = Sheets("Target")
    arrSource = wsSource.Range("A1").CurrentRegion.Value
    lNumProjects = UBound(arrSource, 2) - 3
    ReDim arrData(1 To lNumProjects * (UBound(arrSource, 1) - 1), 1 To 5)

    For rIndex = 2 To UBound(arrSource, 1)
        For cIndex = 1 To lNumProjects
            DataIndex = DataIndex + 1
            arrData(DataIndex, 1) = arrSource(rIndex, 1)
            arrData(DataIndex, 2) = arrSource(rIndex, 2)
            arrData(DataIndex, 3) = arrSource(rIndex, 3)
            arrData(DataIndex, 4) = arrSource(1, cIndex + 3)
            arrData(DataIndex, 5) = arrSource(rIndex, cIndex + 3)
        Next cIndex
    Next rIndex

    If DataIndex > 0 Then
        wsTarget.Range("A2:E" & Rows.Count).ClearContents
        wsTarget.Range("A2:E2").Resize(DataIndex).Value = arrData
    End If

    Set wsSource = Nothing
    Set wsTarget = Nothing
    Erase arrSource
    Erase arrData

End Sub

Answer 2

我的博客上有两篇关于在 Excel/VBA 中执行此操作的帖子，其中包含可用的代码和可下载的工作簿：

http://yoursumbuddy.com/data-normalizer

http://yoursumbuddy.com/data-normalizer-the-sql/

这是代码：

'Arguments
'List: The range to be normalized.
'RepeatingColsCount: The number of columns, starting with the leftmost,
'   whose headings remain the same.
'NormalizedColHeader: The column header for the rolled-up category.
'DataColHeader: The column header for the normalized data.
'NewWorkbook: Put the sheet with the data in a new workbook?
'
'NOTE: The data must be in a contiguous range and the
'rows that will be repeated must be to the left,
'with the rows to be normalized to the right.

Sub NormalizeList(List As Excel.Range, RepeatingColsCount As Long, _
    NormalizedColHeader As String, DataColHeader As String, _
    Optional NewWorkbook As Boolean = False)

Dim FirstNormalizingCol As Long, NormalizingColsCount As Long
Dim ColsToRepeat As Excel.Range, ColsToNormalize As Excel.Range
Dim NormalizedRowsCount As Long
Dim RepeatingList() As String
Dim NormalizedList() As Variant
Dim ListIndex As Long, i As Long, j As Long
Dim wbSource As Excel.Workbook, wbTarget As Excel.Workbook
Dim wsTarget As Excel.Worksheet

With List
    'If the normalized list won't fit, you must quit.
   If .Rows.Count * (.Columns.Count - RepeatingColsCount) > .Parent.Rows.Count Then
        MsgBox "The normalized list will be too many rows.", _
               vbExclamation + vbOKOnly, "Sorry"
        Exit Sub
    End If

    'You have the range to be normalized and the count of leftmost rows to be repeated.
   'This section uses those arguments to set the two ranges to parse
   'and the two corresponding arrays to fill
   FirstNormalizingCol = RepeatingColsCount + 1
    NormalizingColsCount = .Columns.Count - RepeatingColsCount
    Set ColsToRepeat = .Cells(1).Resize(.Rows.Count, RepeatingColsCount)
    Set ColsToNormalize = .Cells(1, FirstNormalizingCol).Resize(.Rows.Count, NormalizingColsCount)
    NormalizedRowsCount = ColsToNormalize.Columns.Count * .Rows.Count
    ReDim RepeatingList(1 To NormalizedRowsCount, 1 To RepeatingColsCount)
    ReDim NormalizedList(1 To NormalizedRowsCount, 1 To 2)
End With

'Fill in every i elements of the repeating array with the repeating row labels.
For i = 1 To NormalizedRowsCount Step NormalizingColsCount
    ListIndex = ListIndex + 1
    For j = 1 To RepeatingColsCount
        RepeatingList(i, j) = List.Cells(ListIndex, j).Value2
    Next j
Next i

'We stepped over most rows above, so fill in other repeating array elements.
For i = 1 To NormalizedRowsCount
    For j = 1 To RepeatingColsCount
        If RepeatingList(i, j) = "" Then
            RepeatingList(i, j) = RepeatingList(i - 1, j)
        End If
    Next j
Next i

'Fill in each element of the first dimension of the normalizing array
'with the former column header (which is now another row label) and the data.
With ColsToNormalize
    For i = 1 To .Rows.Count
        For j = 1 To .Columns.Count
            NormalizedList(((i - 1) * NormalizingColsCount) + j, 1) = .Cells(1, j)
            NormalizedList(((i - 1) * NormalizingColsCount) + j, 2) = .Cells(i, j)
        Next j
    Next i
End With

'Put the normal data in the same workbook, or a new one.
If NewWorkbook Then
    Set wbTarget = Workbooks.Add
    Set wsTarget = wbTarget.Worksheets(1)
Else
    Set wbSource = List.Parent.Parent
    With wbSource.Worksheets
        Set wsTarget = .Add(after:=.Item(.Count))
    End With
End If

With wsTarget
    'Put the data from the two arrays in the new worksheet.
   .Range("A1").Resize(NormalizedRowsCount, RepeatingColsCount) = RepeatingList
    .Cells(1, FirstNormalizingCol).Resize(NormalizedRowsCount, 2) = NormalizedList

    'At this point there will be repeated header rows, so delete all but one.
   .Range("1:" & NormalizingColsCount - 1).EntireRow.Delete

    'Add the headers for the new label column and the data column.
   .Cells(1, FirstNormalizingCol).Value = NormalizedColHeader
    .Cells(1, FirstNormalizingCol + 1).Value = DataColHeader
End With
End Sub

你会这样称呼它：

Sub TestIt()
NormalizeList ActiveSheet.UsedRange, 4, "Variable", "Value", False
End Sub

Answer 3

尝试在此处使用我的 unpivot 加载项进行 unpivoting：http: //tduhameau.wordpress.com/2012/09/24/the-unpivot-add-in/