在excel中使用VBA将行数据排列到列中？

Question

我正在调整问题：Re-Arranging the row data in columns

我的Excel数据设置如下;

Collection  LatDD   LonDD   Date Location   Method  Specie1 Specie2 Specie3(+-110 species columns in total)     
 ABS1       11.35   -10.3   2003-02-01  A   Bucket      0      1       3       
 ABS2       11.36   -10.4   2003-02-02  B   Stick       2      0       6

我希望此数据显示如下：

Collection  Specie  Count LatDD LonDD    Date       Location  Method
 ABS1        Specie1       11.35  -10.3  2003-02-01     A       Bucket
 ABS1        Specie2   1   11.35  -10.3  2003-02-01     A      Bucket
 ABS1        Specie3   3   11.35  -10.3  2003-02-01     A      Bucket
 ABS2        Specie1   2   11.36  -10.4  2003-02-02     B      Stick
 ABS2        Specie2      -11.36  -10.4  2003-02-02     B       Stick
 ABS2        Specie3   6  -11.36  -10.4  2003-02-02     B       Stick

我试图改编Ripsters原始的VBA代码答案，但不幸的是我无法弄清楚我将如何更改它。 有人可以告诉我如何调整代码以产生所需的输出吗？

这是他的原始vba代码：

Sub Example()
    Dim Resources() As String
    Dim rng As Range
    Dim row As Long
    Dim col As Long
    Dim x As Long

    ReDim Resources(1 To (ActiveSheet.UsedRange.Rows.Count - 1) * (ActiveSheet.UsedRange.Columns.Count - 1), 1 To 3)

    'Change this to the source sheet
    Sheets("Sheet1").Select

    'Read data into an array
    For row = 2 To ActiveSheet.UsedRange.Rows.Count
        For col = 2 To ActiveSheet.UsedRange.Columns.Count
            x = x + 1
            Resources(x, 1) = Cells(row, 1).Value    ' Get name
            Resources(x, 2) = Cells(1, col).Value    ' Get date
            Resources(x, 3) = Cells(row, col).Value  ' Get value
        Next
    Next

    'Change this to the destination sheet
    Sheets("Sheet2").Select

    'Write data to sheet
    Range(Cells(1, 1), Cells(UBound(Resources), UBound(Resources, 2))).Value = Resources

    'Insert column headers
    Rows(1).Insert
    Range("A1:C1").Value = Array("Resource", "Date", "Value")

    'Set strings to values
    Set rng = Range(Cells(1, 3), Cells(ActiveSheet.UsedRange.Rows.Count, 3))
    rng.Value = rng.Value
End Sub

Answer 1

试试这个：

Sub Example()
    Dim row As Long
    Dim col As Long
    Dim x As Long

    h1 = "Sheet1"
    h2 = "Sheet2"
    Sheets(h1).Select
    x = 2
    'Headers Sheet2
    Sheets(h2).Cells(1, 1).Value = Sheets(h1).Cells(1, 1)
    Sheets(h2).Cells(1, 2).Value = "Specie"
    Sheets(h2).Cells(1, 3).Value = "Count"
    Sheets(h2).Cells(1, 4).Value = Sheets(h1).Cells(1, 2)
    Sheets(h2).Cells(1, 5).Value = Sheets(h1).Cells(1, 3)
    Sheets(h2).Cells(1, 6).Value = Sheets(h1).Cells(1, 4)
    Sheets(h2).Cells(1, 7).Value = Sheets(h1).Cells(1, 5)
    Sheets(h2).Cells(1, 8).Value = Sheets(h1).Cells(1, 6)

    For row = 2 To ActiveSheet.UsedRange.Rows.Count
        For col = 7 To ActiveSheet.UsedRange.Columns.Count
            Sheets(h2).Cells(x, 1).Value = Sheets(h1).Cells(row, 1).Value
            Sheets(h2).Cells(x, 2).Value = Sheets(h1).Cells(1, col).Value
            Sheets(h2).Cells(x, 3).Value = Sheets(h1).Cells(row, col).Value
            Sheets(h2).Cells(x, 4).Value = Sheets(h1).Cells(row, 2).Value
            Sheets(h2).Cells(x, 5).Value = Sheets(h1).Cells(row, 3).Value
            Sheets(h2).Cells(x, 6).Value = Sheets(h1).Cells(row, 4).Value
            Sheets(h2).Cells(x, 7).Value = Sheets(h1).Cells(row, 5).Value
            Sheets(h2).Cells(x, 8).Value = Sheets(h1).Cells(row, 6).Value
            x = x + 1
        Next
    Next
End Sub

Sheet 1中：

Sheet 2中：

简短的文章：

Sub Example()
    Dim row As Long
    Dim col As Long
    Dim x As Long

    Set Sh1 = ThisWorkbook.Worksheets("Sheet1")
    Set Sh2 = ThisWorkbook.Worksheets("Sheet2")
    Sh1.Select

    'Headers Sheet2
    Sh2.Cells(1, 1).Value = Sh1.Cells(1, 1)
    Sh2.Cells(1, 2).Value = "Specie"
    Sh2.Cells(1, 3).Value = "Count"
    For i = 4 To 8
        Sh2.Cells(1, i).Value = Sh1.Cells(1, i - 2)
    Next
    x = 2 'Starting row of sheet2.
    For row = 2 To ActiveSheet.UsedRange.Rows.Count
        For col = 7 To ActiveSheet.UsedRange.Columns.Count
            Sh2.Cells(x, 1).Value = Sh1.Cells(row, 1).Value
            Sh2.Cells(x, 2).Value = Sh1.Cells(1, col).Value
            Sh2.Cells(x, 3).Value = Sh1.Cells(row, col).Value
            For i = 4 To 8
                Sh2.Cells(x, i).Value = Sh1.Cells(row, i - 2).Value
            Next
            x = x + 1
        Next
    Next
    Sh2.Select
End Sub

Answer 2

另一个想法......

您的源数据位于“Sheet1”中，从“A1”开始，A列和第1行都没有空值。

如果您运行代码，您将获得“Sheet2”中的重新排序表（我省略了标题，但是 - 太懒了......）

希望这有帮助

Sub sort_new()


Dim col_no As Long, row_no As Long
Dim i As Long, j As Long, k As Long
Dim arr_DB As Variant, arr_new As Variant
Dim ws1 As Worksheet, ws2 As Worksheet

Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")

ws1.Activate

row_no = ws1.Range(Cells(Rows.Count, 1), Cells(Rows.Count, 1)).End(xlUp).Row
col_no = ws1.Range(Cells(1, Columns.Count), Cells(1, Columns.Count)).End(xlToLeft).Column

arr_DB = ws1.Range(Cells(1, 1), Cells(row_no, col_no))

ReDim arr_new(1 To (row_no - 1) * (col_no - 6), 1 To 8)

For i = 2 To row_no
    For j = 7 To col_no
        k = k + 1
        arr_new(k, 1) = arr_DB(i, 1) 'Collection
        arr_new(k, 4) = arr_DB(i, 2) 'LatDD
        arr_new(k, 5) = arr_DB(i, 3) 'LonDD
        arr_new(k, 6) = arr_DB(i, 4) 'Date
        arr_new(k, 7) = arr_DB(i, 5) 'Location
        arr_new(k, 8) = arr_DB(i, 6) 'Method
        arr_new(k, 2) = arr_DB(1, j) 'Each Specie(j) Column
        arr_new(k, 3) = arr_DB(i, j) 'Each Specie(j) Column
               
    Next
Next
    
ws2.Activate

ws2.Range(Cells(2, 1), Cells((row_no - 1) * (col_no - 6) + 1, 8)) = arr_new

End Sub