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

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

源结构

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

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

目标数据结构

这些数据将会定期更新，新的条目将被添加到源代码的底部。 我已经想出了如何遍历一系列的数据，但不知道如何select单个单元格写在下一张纸上。 我是一个VBA新手，所以任何帮助，将不胜感激。

Answer 1

我有两篇文章，包括可用的代码和可下载的工作簿，在我的博客上的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 2

您需要将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 3

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