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

我正在适应这个问题：

我的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

我试图改编成熟的原始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

试试这个：

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

表1：

第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

另一个想法

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

如果您运行代码，您将在“Sheet2”中得到重新排序的表（尽管我省略了标题-太懒了…）

希望这有帮助

Sub-sort_new（）
暗淡的颜色不一样长，排不一样长
我长，j长，k长
作为变型的Dim arr_DB，作为变型的arr_新
将ws1标注为工作表，将ws2标注为工作表
设置ws1=ThisWorkbook.Worksheets（“Sheet1”）
设置ws2=ThisWorkbook.Worksheets（“Sheet2”）
ws1.激活
row_no=ws1.Range（单元格（Rows.Count，1），单元格（Rows.Count，1））.End（xlUp）.row
col_no=ws1.Range（单元格（1，Columns.Count），单元格（1，Columns.Count））.End（xlToLeft）.Column
arr_DB=ws1.范围（单元格（1，1），单元格（行号，列号））
雷迪姆新机场（1至（第1排）*（第6排），第1至8排）
对于i=2至第号行
对于j=7至列号
k=k+1
arr_new（k，1）=arr_DB（i，1）'集合
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）”日期
arr_new（k，7）=arr_DB（i，5）”位置
arr_-new（k，8）=arr_-DB（i，6）'方法
arr_new（k，2）=arr_DB（1，j）'每种（j）列
arr_new（k，3）=arr_DB（i，j）'每种（j）列
下一个
下一个
ws2.激活
ws2.Range（单元格（2，1），单元格（（第1行）*（第6列）+1，8））=arr\u new
末端接头

枢轴怎么样？还是取消？我会试试的now@Leptonator不幸的是，我要处理的是110多个列，我真的需要vbaPower查询（2010年的外接程序，或2013年的内置程序）有一个UNpivot函数，该函数将适用于任何需要取消pivot的列。这里的例子：我有Excel 2013，但是Power Query不会下载，因为它说我没有必要的MS Excel，我使用时出现的表格如下；集合物种计数物种计数物种计数物种计数物种计数计数0计数0计数0计数3计数0计数6计数1计数3计数0计数0计数0计数1计数0计数1计数0计数0计数1计数0计数1计数1计数0计数1计数1计数1计数物种计数0计数1计数6计数6计数0计数未计数确定发生了什么事wrong@user3726345确保您的数据从sheet1 A1开始，并且格式与您发布的相同。我尝试了你发布的格式，我没有遇到任何问题。它很有效，谢谢！我在计数列上遇到了问题，但多亏了你，它工作得非常好！不生成计数列。