我有一组看起来像这样的数据。
来源结构
但是我想将项目列复制到另一个工作表上的各个行中。在这种情况下,源表中的每一行都会在目标表中生成四行,因为有四个项目。
这是所需目标数据结构的图片。
目标数据结构
此数据将定期更改,新条目将添加到源的底部。我已经弄清楚如何循环一系列数据,但无法弄清楚如何在下一张纸上选择单个单元格进行写入。我是VBA的新手,所以任何帮助都会受到赞赏。
答案 0 :(得分: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
答案 1 :(得分: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
答案 2 :(得分:0)
在此处使用我的unpivot加载项尝试解除隐私:http://tduhameau.wordpress.com/2012/09/24/the-unpivot-add-in/