修正了列到行

数据分布在列上

要保持前三列固定（列a，b和c）。

并从四个转换列到新行（列d – >最后一列有值）。

例：

从D – >列的颜色并不总是绿色，蓝色，黑色红色等……它们根据从电源查询表中加载的数据而变化。

这就是我想要的数据：

注意列A，B和C是如何用相同的信息修复的，只有D列向前重新创build一个新的“行”。

我一直在尝试从以前的post中修改VBA脚本，但是我遇到了一些麻烦。 我也试图将它保留在数据当前所在的工作表上，而不是创build一个新工作表。 如果只是创build一个新的表格更容易，那么我可以用它..脚本：

Sub ColumnTorow() Dim maxRows As Double Dim maxCols As Integer Dim data As Variant maxRows = Cells(1, 1).End(xlDown).row maxCols = Cells(1, 1).End(xlToRight).Column data = Range(Cells(1, 1), Cells(maxRows, maxCols)) With ActiveSheet Dim rRow As Long rRow = 2 Dim row As Long row = 2 Dim col As Integer Do While True col = 2 Do While True If data(row, col) = "" Then Exit Do 'Skip Blanks .Cells(rRow, 1).Value = data(row, 1) .Cells(rRow, 2).Value = data(row, col) rRow = rRow + 1 If col = maxCols Then Exit Do 'Exit clause col = col + 1 Loop If row = maxRows Then Exit Do 'exit cluase row = row + 1 Loop End With End Sub 

这只是我提供的一个示例代码，我试图修改…它可能不是这个问题的正确解决scheme，但认为我会发布它反正。

Answer 1

在这里你走了，因为我昨天做了这件事，所以我很快就把它弄到一起了：

 Sub ColumnToRow() Dim maxRows As Double Dim maxCols As Integer Dim data As Variant maxRows = Cells(1, 1).End(xlDown).row maxCols = Cells(1, 1).End(xlToRight).Column data = Range(Cells(1, 1), Cells(maxRows, maxCols)) Dim newSht As Worksheet Set newSht = Sheets.Add With newSht .Cells(1, 1).Value = data(1, 1) .Cells(1, 2).Value = data(1, 2) .Cells(1, 3).Value = data(1, 3) .Cells(1, 4).Value = data(1, 4) Dim writeColumn As Double writeColumn = 1 Dim writeRow As Double writeRow = 2 Dim row As Double row = 2 Do writeColumn = 1 Dim col As Double col = 4 Do While True If data(row, col) <> "" Then Dim firstColData As String firstColData = data(row, 1) .Cells(writeRow, writeColumn) = firstColData writeColumn = 2 Dim secondColData As String secondColData = data(row, 2) .Cells(writeRow, writeColumn) = secondColData writeColumn = 3 Dim thirdColData As String thirdColData = data(row, 3) .Cells(writeRow, writeColumn) = thirdColData writeColumn = 4 .Cells(writeRow, writeColumn).Value = data(row, col) writeColumn = 1 writeRow = writeRow + 1 End If If col = maxCols Then Exit Do 'Exit clause End If col = col + 1 Loop If row = maxRows Then Exit Do 'exit cluase End If row = row + 1 Loop While True End With End Sub 

Answer 2

考虑这个代码。

 Sub TransData() Dim vDB, vR() Dim n As Long, i As Long, j As Integer, k As Integer vDB = Range("a1").CurrentRegion For i = 2 To UBound(vDB, 1) For j = 4 To UBound(vDB, 2) If vDB(i, j) <> "" Then n = n + 1 ReDim Preserve vR(1 To 4, 1 To n) For k = 1 To 3 vR(k, n) = vDB(i, k) Next k vR(4, n) = vDB(i, j) End If Next j Next i Sheets.Add Range("a1").Resize(1, 4) = Array("Item", "Amount", "Price", "Color") Range("a2").Resize(n, 4) = WorksheetFunction.Transpose(vR) End Sub