excel vba我需要将数据从列转置到行

我正在寻找一个VBA解决scheme来转换类似于下图所示的场景中的数据。 从Sheet1复制前三个单元格值（A3，B3，C3），只有当Sheet2中的任何单元格中的值（D3，E3，…）超过前3个单元格值（A2，B2，C2） ），之后的值为（D3）的第一个单元格，并将标题值复制到相邻的单元格中。 左侧的任何附加值得到相同的处理，并成为下一行，再次复制（A3，B3，C3）。 然后将下一个相邻小区值（E3）连同报头值一起放入相邻小区。 然后向下移动到Sheet1中的下一行，其中第一个3个单元格之后有值，直到它在Sheet1中一直循环以生成Sheet2的示例。

我已经寻找其他类似的解决scheme，但找不到任何可行的方法。 这是我发现的最小的编辑，但我不能工作，任何帮助，不胜感激。

 Sub Sample() Dim wsThis As Worksheet Dim wsThat As Worksheet Dim ThisAr As Variant Dim ThatAr As Variant Dim Lrow As Long Dim Col As Long Dim i As Long Dim k As Long Set wsThis = Sheet1: Set wsThat = Sheet2 With wsThis '~~> Find Last Row in Col A Lrow = .Range("A" & .Rows.Count).End(xlUp).Row '~~> Find total value in D,E,F so that we can define output array Col = Application.WorksheetFunction.CountA(.Range("C2:G" & Lrow)) '~~> Store the values from the range in an array ThisAr = .Range("A2:G" & Lrow).Value '~~> Define your new array ReDim ThatAr(1 To Col, 1 To 7) '~~> Loop through the array and store values in new array For i = LBound(ThisAr) To UBound(ThisAr) k = k + 1 ThatAr(k, 1) = ThisAr(i, 1) ThatAr(k, 2) = ThisAr(i, 2) ThatAr(k, 3) = ThisAr(i, 3) '~~> Check for Color 1 If ThisAr(i, 5) <> "" Then 'ThatAr(k, 4) = ThisAr(i, 4) k = k + 1 ThatAr(k, 1) = ThisAr(i, 1) ThatAr(k, 2) = ThisAr(i, 2) ThatAr(k, 3) = ThisAr(i, 3) ThatAr(k, 4) = ThisAr(i, 4) ThatAr(k, 5) = ThisAr(i, 5) End If '~~> Check for Color 2 If ThisAr(i, 7) <> "" Then k = k + 1 ThatAr(k, 1) = ThisAr(i, 1) ThatAr(k, 2) = ThisAr(i, 2) ThatAr(k, 3) = ThisAr(i, 3) ThatAr(k, 6) = ThisAr(i, 6) ThatAr(k, 7) = ThisAr(i, 7) End If '~~> Check for Color 3 'If ThisAr(i, 6) <> "" Then 'k = k + 1 'ThatAr(k, 1) = ThisAr(i, 1) 'ThatAr(k, 2) = ThisAr(i, 2) 'ThatAr(k, 3) = ThisAr(i, 3) 'ThatAr(k, 4) = ThisAr(i, 6) 'End If Next i End With '~~> Create headers in Sheet2 Sheet2.Range("A1:D1").Value = Sheet1.Range("A1:D1").Value '~~> Output the array wsThat.Range("A2").Resize(Col, 4).Value = ThatAr End Sub 

Answer 1

使用变体数组（dynamic数组）是简单而快速的。

 Sub test() Dim wsThis As Worksheet, wsThat As Worksheet Dim vDB As Variant, vR() As Variant Dim r As Long, i As Long, n As Long Dim c As Integer, j As Integer, k As Integer Set wsThis = Sheet1: Set wsThat = Sheet2 vDB = wsThis.Range("a1").CurrentRegion r = UBound(vDB, 1) c = UBound(vDB, 2) For i = 2 To r For j = 4 To c If vDB(i, j) <> "" Then n = n + 1 ReDim Preserve vR(1 To 5, 1 To n) For k = 1 To 3 vR(k, n) = vDB(i, k) Next k vR(4, n) = vDB(i, j) vR(5, n) = vDB(1, j) End If Next j Next i With wsThat .UsedRange.Clear .Range("a1").Resize(1, 3) = wsThis.Range("a1").Resize(1, 3).Value .Range("d1").Resize(1, 2) = Array("Value", "ID#") .Range("a2").Resize(n, 5) = WorksheetFunction.Transpose(vR) End With End Sub 

Answer 2

抱歉，我不确定为什么我无法打开附加的图片。 但是你可能想试试这个代码：

 Change this line: wsThat.Range("A2").Resize(Col, 4).Value = ThatAr To wsThat.Range("A2").Resize(4, Col).Value = WorksheetFunction.Transpose(ThatAr) 

希望这个帮助