vba 如何将二维 Excel 表格“展平”或“折叠”为一维？

How to "flatten" or "collapse" a 2D Excel table into 1D?

提问by emmby

I have a two dimensional table with countries and years in Excel. eg.

我在 Excel 中有一个包含国家和年份的二维表。例如。

        1961        1962        1963        1964
USA      a           x            g           y
France   u           e            h           a
Germany  o           x            n           p

I'd like to "flatten" it, such that I have Country in the first col, Year in the second col, and then value in the third col. eg.

我想“展平”它，这样我在第一列中有国家，在第二列中有年份，然后在第三列中有值。例如。

Country      Year       Value
USA          1961       a
USA          1962       x
USA          1963       g
USA          1964       y
France       1961       u
              ...

The example I present here is only a 3x4 matrix, but the real dataset i have is significantly larger (roughly 50x40 or so).

我在这里展示的示例只是一个 3x4 矩阵，但我拥有的真实数据集要大得多（大约 50x40 左右）。

Any suggestions how I can do this using Excel?

任何建议如何使用 Excel 执行此操作？

采纳答案by Adam Davis

You can use the excel pivot table feature to reverse a pivot table (which is essentially what you have here):

您可以使用 excel 数据透视表功能来反转数据透视表（这实际上就是您在此处拥有的）：

Good instructions here:

这里有很好的说明：

http://spreadsheetpage.com/index.php/tip/creating_a_database_table_from_a_summary_table/

http://spreadsheetpage.com/index.php/tip/creating_a_database_table_from_a_summary_table/

Which links to the following VBA code (put it in a module) if you don't want to follow the instructions by hand:

如果您不想手动按照说明操作，请链接到以下 VBA 代码（将其放入模块中）：

Sub ReversePivotTable()
'   Before running this, make sure you have a summary table with column headers.
'   The output table will have three columns.
    Dim SummaryTable As Range, OutputRange As Range
    Dim OutRow As Long
    Dim r As Long, c As Long

    On Error Resume Next
    Set SummaryTable = ActiveCell.CurrentRegion
    If SummaryTable.Count = 1 Or SummaryTable.Rows.Count < 3 Then
        MsgBox "Select a cell within the summary table.", vbCritical
        Exit Sub
    End If
    SummaryTable.Select
    Set OutputRange = Application.InputBox(prompt:="Select a cell for the 3-column output", Type:=8)
'   Convert the range
    OutRow = 2
    Application.ScreenUpdating = False
    OutputRange.Range("A1:C3") = Array("Column1", "Column2", "Column3")
    For r = 2 To SummaryTable.Rows.Count
        For c = 2 To SummaryTable.Columns.Count
            OutputRange.Cells(OutRow, 1) = SummaryTable.Cells(r, 1)
            OutputRange.Cells(OutRow, 2) = SummaryTable.Cells(1, c)
            OutputRange.Cells(OutRow, 3) = SummaryTable.Cells(r, c)
            OutputRange.Cells(OutRow, 3).NumberFormat = SummaryTable.Cells(r, c).NumberFormat
            OutRow = OutRow + 1
        Next c
    Next r
End Sub

-Adam

-亚当

回答by Michael La Voie

@Adam Davis's answer is perfect, but just in case you're as clueless as I am about Excel VBA, here's what I did to get the code working in Excel 2007:

@Adam Davis 的回答是完美的，但以防万一您和我一样对 Excel VBA 一无所知，以下是我为使代码在 Excel 2007 中运行所做的工作：

1. Open the workbook with the Matrix that needs to be flattened to a table and navigate to that worksheet
2. Press Alt-F11 to open the VBA code editor.
3. On the left pane, in the Project box, you'll see a tree structure representing the excel objects and any code (called modules) that already exist. Right click anywhere in the box and select "Insert->Module" to create a blank module file.
4. Copy and paste @Adman Davis's code from above as is into the blank page the opens and save it.
5. Close the VBA editor window and return to the spreadsheet.
6. Click on any cell in the matrix to indicate the matrix you'll be working with.
7. Now you need to run the macro. Where this option is will vary based on your version of Excel. As I'm using 2007, I can tell you that it keeps its macros in the "View" ribbon as the farthest right control. Click it and you'll see a laundry list of macros, just double click on the one called "ReversePivotTable" to run it.
8. It will then show a popup asking you to tell it where to create the flattened table. Just point it to any empty space an your spreadsheet and click "ok"

1. 打开包含需要展平为表格的矩阵的工作簿并导航到该工作表
2. 按 Alt-F11 打开 VBA 代码编辑器。
3. 在左侧窗格的“项目”框中，您将看到一个树结构，表示 Excel 对象和任何已存在的代码（称为模块）。右键单击框中的任意位置并选择“插入->模块”以创建一个空白模块文件。
4. 将上面@Adman Davis 的代码按原样复制并粘贴到打开的空白页面中并保存。
5. 关闭 VBA 编辑器窗口并返回到电子表格。
6. 单击矩阵中的任何单元格以指示您将使用的矩阵。
7. 现在您需要运行宏。此选项的位置将根据您的 Excel 版本而有所不同。当我使用 2007 时，我可以告诉您，它会将其宏保留在“视图”功能区中，作为最远的右侧控件。单击它，您将看到一长串宏，只需双击名为“ReversePivotTable”的宏即可运行它。
8. 然后它会显示一个弹出窗口，要求您告诉它在哪里创建扁平表格。只需将其指向电子表格中的任何空白区域，然后单击“确定”

You're done! The first column will be the rows, the second column will be the columns, the third column will be the data.

你完成了！第一列是行，第二列是列，第三列是数据。

回答by vladimir

In Excel 2013 need to follow next steps:

在 Excel 2013 中需要遵循以下步骤：

• select data and convert to table (Insert -> Table)
• call Query Editor for table (Power Query -> From Table)
• select columns that contain years
• in context menu select 'Unpivot Columns'-command.

• 选择数据并转换为表格（插入 -> 表格）
• 为表调用查询编辑器（Power Query -> From Table）
• 选择包含年份的列
• 在上下文菜单中选择“ Unpivot Columns”命令。

Support Office: Unpivot columns (Power Query)

支持办公室：逆透视列 (Power Query)

回答by vladimir

Flattening a data matrix (aka Table) can be accomplished with one array formula1 and two standard formulas.

扁平数据矩阵（又名Table）可以通过一个数组公式1和两个标准公式来完成。

??????

？？？？？？

The array formula1 and two standard formulas in G3:I3 are is,

G3:I3中的数组公式1和两个标准公式是，

=IFERROR(INDEX(A:A, MATCH(0, IF(COUNTIF(G:G2, A:A&"")<COUNT(:), 0, 1), 0)), "")
=IF(LEN(G3), INDEX($B:INDEX(:, MATCH(1E+99,: )), , COUNTIF(G:G3, G3)), "")
=INDEX(A:J,MATCH(G3,A:A,0),MATCH(H3,:,0))

Fill down as necessary.

根据需要填写。

While array formulas can negatively impact performance due to their cyclic calculation, your described working environment of 40 rows × 50 columns should not overly impact performance with a calculation lag.

虽然数组公式会因其循环计算而对性能产生负面影响，但您所描述的 40 行 × 50 列的工作环境不应因计算滞后而过度影响性能。

---

---

1 _{Array formulas need to be finalized with Ctrl+Shift+Enter?. Once entered into the first cell correctly, they can be filled or copied down or right just like any other formula. Try and reduce full-column references to ranges more closely representing the extents of your actual data. Array formulas chew up calculation cycles logarithmically so it is good practise to narrow the referenced ranges to a minimum. See Guidelines and examples of array formulasfor more information.}

1个_{数组公式需要用敲定Ctrl+ Shift+ Enter?。正确输入第一个单元格后，它们可以像任何其他公式一样填充或向下或向右复制。尝试将全列引用减少到更接近代表实际数据范围的范围。数组公式以对数方式消耗计算周期，因此将引用范围缩小到最小值是一种很好的做法。有关更多信息，请参阅数组公式的准则和示例。}

回答by Pricey

For anyone who wants to use the PivotTable to do this and is following the below guide: http://spreadsheetpage.com/index.php/tip/creating_a_database_table_from_a_summary_table/

对于想要使用数据透视表执行此操作并遵循以下指南的任何人：http: //spreadsheetpage.com/index.php/tip/creating_a_database_table_from_a_summary_table/

If you want to do it in Excel 2007 or 2010 then you first need to enable the PivotTable Wizard.

如果要在 Excel 2007 或 2010 中执行此操作，则首先需要启用数据透视表向导。

To find the option you need to go to "Excel Options" via the Main Excel Window icon, and see the options selected in the "customize" section, then select "Commands Not in the Ribbon" from the "Choose Commands from:" dropdown and "PivotTable and PivotChart Wizard" needs to be added to the right.. see the image below.

要找到您需要通过主 Excel 窗口图标转到“Excel 选项”的选项，并查看在“自定义”部分中选择的选项，然后从“从以下位置选择命令”下拉列表中选择“不在功能区中的命令”和“数据透视表和数据透视图向导”需要添加到右侧..见下图。

Once that is done there should be a small pivottable wizard icon in the quickbar menu at the top of the Excel window, you can then follow the same process as shown in the link above.

完成后，Excel 窗口顶部的快速栏菜单中应该会有一个小的数据透视表向导图标，然后您可以按照上面链接中显示的相同过程进行操作。

回答by Delcroip

I developed another macro because I needed to refresh the output table quite often (input table was filled by other) and I wanted to have more info in my output table (more copied column and some formulas)

我开发了另一个宏，因为我需要经常刷新输出表（输入表由其他人填充）并且我想在我的输出表中包含更多信息（更多复制的列和一些公式）

Sub TableConvert()

Dim tbl As ListObject 
Dim t
Rows As Long
Dim tCols As Long
Dim userCalculateSetting As XlCalculation
Dim wrksht_in As Worksheet
Dim wrksht_out As Worksheet

'##block calculate and screen refresh
Application.ScreenUpdating = False
userCalculateSetting = Application.Calculation
Application.Calculation = xlCalculationManual

'## get the input and output worksheet
Set wrksht_in = ActiveWorkbook.Worksheets("ressource_entry")'## input
Set wrksht_out = ActiveWorkbook.Worksheets("data")'## output.


'## get the table object from the worksheet
Set tbl = wrksht_in.ListObjects("Table14")  '## input
Set tb2 = wrksht_out.ListObjects("Table2") '## output.

'## delete output table data
If Not tb2.DataBodyRange Is Nothing Then
    tb2.DataBodyRange.Delete
End If

'## count the row and col of input table

With tbl.DataBodyRange
     tRows = .Rows.Count
     tCols = .Columns.Count
End With

'## check every case of the input table (only the data part)
For j = 2 To tRows '## parse all row from row 2 (header are not checked)
    For i = 5 To tCols '## parse all column from col 5 (first col will be copied in each record)
        If IsEmpty(tbl.Range.Cells(j, i).Value) = False Then
            '## if there is time enetered create a new row in table2 by using the first colmn of the selected cell row and cell header plus some formula
            Set oNewRow = tb2.ListRows.Add(AlwaysInsert:=True)
            oNewRow.Range.Cells(1, 1).Value = tbl.Range.Cells(j, 1).Value
            oNewRow.Range.Cells(1, 2).Value = tbl.Range.Cells(j, 2).Value
            oNewRow.Range.Cells(1, 3).Value = tbl.Range.Cells(j, 3).Value
            oNewRow.Range.Cells(1, 4).Value = tbl.Range.Cells(1, i).Value
            oNewRow.Range.Cells(1, 5).Value = tbl.Range.Cells(j, i).Value
            oNewRow.Range.Cells(1, 6).Formula = "=WEEKNUM([@Date])"
            oNewRow.Range.Cells(1, 7).Formula = "=YEAR([@Date])"
            oNewRow.Range.Cells(1, 8).Formula = "=MONTH([@Date])"
        End If
   Next i
Next j
ThisWorkbook.RefreshAll

'##unblock calculate and screen refresh
Application.ScreenUpdating = True 
Application.Calculate
Application.Calculation = userCalculateSetting

End Sub

回答by user9063393

updated ReversePivotTable function so i can specify number of header columns and rows

更新了 ReversePivotTable 函数，以便我可以指定标题列和行的数量

Sub ReversePivotTable()
'   Before running this, make sure you have a summary table with column headers.
'   The output table will have three columns.
    Dim SummaryTable As Range, OutputRange As Range
    Dim OutRow As Long
    Dim r As Long, c As Long

    Dim lngHeaderColumns As Long, lngHeaderRows As Long, lngHeaderLoop As Long

    On Error Resume Next
    Set SummaryTable = ActiveCell.CurrentRegion
    If SummaryTable.Count = 1 Or SummaryTable.Rows.Count < 3 Then
        MsgBox "Select a cell within the summary table.", vbCritical
        Exit Sub
    End If
    SummaryTable.Select

    Set OutputRange = Application.InputBox(prompt:="Select a cell for the 3-column output", Type:=8)
    lngHeaderColumns = Application.InputBox(prompt:="Header Columns")
    lngHeaderRows = Application.InputBox(prompt:="Header Rows")
'   Convert the range
    OutRow = 2
    Application.ScreenUpdating = False
    'OutputRange.Range("A1:D3") = Array("Column1", "Column2", "Column3", "Column4")
    For r = lngHeaderRows + 1 To SummaryTable.Rows.Count
        For c = lngHeaderColumns + 1 To SummaryTable.Columns.Count
            ' loop through all header columns and add to output
            For lngHeaderLoop = 1 To lngHeaderColumns
                OutputRange.Cells(OutRow, lngHeaderLoop) = SummaryTable.Cells(r, lngHeaderLoop)
            Next lngHeaderLoop
            ' loop through all header rows and add to output
            For lngHeaderLoop = 1 To lngHeaderRows
                OutputRange.Cells(OutRow, lngHeaderColumns + lngHeaderLoop) = SummaryTable.Cells(lngHeaderLoop, c)
            Next lngHeaderLoop

            OutputRange.Cells(OutRow, lngHeaderColumns + lngHeaderRows + 1) = SummaryTable.Cells(r, c)
            OutputRange.Cells(OutRow, lngHeaderColumns + lngHeaderRows + 1).NumberFormat = SummaryTable.Cells(r, c).NumberFormat
            OutRow = OutRow + 1
        Next c
    Next r
End Sub

回答by Михаил Попов

Code with the claim for some universality The book should have two sheets: Sour = Source data Dest = the "extended" table will drop here

声称具有普遍性的代码 这本书应该有两张表： Sour = 源数据 Dest = “扩展”表将放在这里

    Option Explicit
    Private ws_Sour As Worksheet, ws_Dest As Worksheet
    Private arr_2d_Sour() As Variant, arr_2d_Dest() As Variant
    ' https://stackoverflow.com/questions/52594461/find-next-available-value-in-excel-cell-based-on-criteria
    Public Sub PullOut(Optional ByVal msg As Variant)
        ws_Dest_Acr _
                arr_2d_ws( _
                arr_2d_Dest_Fill( _
                arr_2d_Sour_Load( _
                arr_2d_Dest_Create( _
                CountA_rng( _
                rng_2d_For_CountA( _
                Init))))))
    End Sub

    Private Function ws_Dest_Acr(Optional ByVal msg As Variant) As Variant
        ws_Dest.Activate
    End Function

    Public Function arr_2d_ws(Optional ByVal msg As Variant) As Variant
        If IsArray(arr_2d_Dest) Then _
           ws_Dest.Cells(1, 1).Resize(UBound(arr_2d_Dest), UBound(arr_2d_Dest, 2)) = arr_2d_Dest
    End Function

    Private Function arr_2d_Dest_Fill(Optional ByVal msg As Variant) As Variant
        Dim y_Sour As Long, y_Dest As Long, x As Long
        y_Dest = 1
        For y_Sour = LBound(arr_2d_Sour) To UBound(arr_2d_Sour)
            ' without the first column
            For x = LBound(arr_2d_Sour, 2) + 1 To UBound(arr_2d_Sour, 2)
                If arr_2d_Sour(y_Sour, x) <> Empty Then
                    arr_2d_Dest(y_Dest, 1) = arr_2d_Sour(y_Sour, 1)    'iD
                    arr_2d_Dest(y_Dest, 2) = arr_2d_Sour(y_Sour, x)    'DTLx
                    y_Dest = y_Dest + 1
                End If
            Next
        Next
    End Function

    Private Function arr_2d_Sour_Load(Optional ByVal msg As Variant) As Variant
        arr_2d_Sour = ReDuce_rng(ws_Sour.UsedRange, 1, 0).Offset(1, 0).Value
    End Function

    Private Function arr_2d_Dest_Create(ByVal iRows As Long)
        Dim arr_2d() As Variant
        ReDim arr_2d(1 To iRows, 1 To 2)
        arr_2d_Dest = arr_2d
        arr_2d_Dest_Create = arr_2d
    End Function

    Public Function CountA_rng(ByVal rng As Range) As Double
        CountA_rng = Application.WorksheetFunction.CountA(rng)
    End Function

    Private Function rng_2d_For_CountA(Optional ByVal msg As Variant) As Range
        ' without the first line and without the left column
        Set rng_2d_For_CountA = _
        ReDuce_rng(ws_Sour.UsedRange, 1, 1).Offset(1, 1)
    End Function

    Public Function ReDuce_rng(rng As Range, ByVal iRow As Long, ByVal iCol As Long) _
           As Range
        With rng
            Set ReDuce_rng = .Resize(.Rows.Count - iRow, .Columns.Count - iCol)
        End With
    End Function

    Private Function Init()
        With ThisWorkbook
            Set ws_Sour = .Worksheets("Sour")
            Set ws_Dest = .Worksheets("Dest")
        End With
    End Function

'https://youtu.be/oTp4aSWPKO0

回答by Vishal Haria

VBA solution may not be acceptable under some situations (e.g. cannot embed macro due to security reasons, etc.). For these situations, and otherwise too in general, I prefer using formulae over macro.

VBA 解决方案在某些情况下可能不可接受（例如，由于安全原因无法嵌入宏等）。对于这些情况，以及在其他情况下，我更喜欢使用公式而不是宏。

I am trying to describe my solution below.

我试图在下面描述我的解决方案。

• input data as shown in question (B2:F5)
• column_header (C2:F2)
• row_header (B3:B5)
• data_matrix (C3:F5)
• no_of_data_rows (I2) = COUNTA(row_header) + COUNTBLANK(row_header)
• no_of_data_columns (I3) = COUNTA(column_header) + COUNTBLANK(column_header)
• no_output_rows (I4) = no_of_data_rows*no_of_data_columns
• seed area is K2:M2, which is blank but referenced, hence not to be deleted
• K3 (drag through say K100, see comments description) = ROW()-ROW($K$2) <= no_output_rows
• L3 (drag through say L100, see comments description) = IF(K3,IF(COUNTIF($L$2:L2,L2)
• M3 (drag through say M100, see comments description) = IF(K3,IF(M2 < no_of_data_columns,M2+1,1),"-")
• N3 (drag through say N100, see comments description) = INDEX(row_header,L3)
• O3 (drag through say O100, see comments description) = INDEX(column_header,M3)
• P3 (drag through say P100, see comments description) = INDEX(data_matrix,L3,M3)
• Comment in K3: Optional: Check if expected no. of output rows has been achieved. Not required, if one only prepares this table limited to no. of output rows.
• Comment in L3: Goal: Each RowIndex (1 .. no_of_data_rows) must repeat no_of_data_columns times. This will provide index lookup for row_header values. In this example, each RowIndex (1 .. 3) must repeat 4 times. Algorithm: Check how many times RowIndex has occurred yet. If it less than no_of_data_columns times, continue using that RowIndex, else increment the RowIndex. Optional: Check if expected no. of output rows has been achieved.
• Comment in M3: Goal: Each ColumnIndex (1 .. no_of_data_columns) must repeat in a cycle. This will provide index lookup for column_header values. In this example, each ColumnIndex (1 .. 4) must repeat in a cycle. Algorithm: If ColumnIndex exceeds no_of_data_columns, restart the cycle at 1, else increment the ColumnIndex. Optional: Check if expected no. of output rows has been achieved.
• Comment in R4: Optional: Use column K for error handling, as shown in column L and column M. Check if looked up value IsBlank to avoid incorrect "0" in the output because of blank input in data_matrix.

• 输入数据如问题所示 (B2:F5)
• column_header (C2:F2)
• row_header (B3:B5)
• 数据矩阵 (C3:F5)
• no_of_data_rows (I2) = COUNTA(row_header) + COUNTBLANK(row_header)
• no_of_data_columns (I3) = COUNTA(column_header) + COUNTBLANK(column_header)
• no_output_rows (I4) = no_of_data_rows*no_of_data_columns
• 种子区为K2:M2，为空但已引用，不删除
• K3（拖动说 K100，请参阅评论说明）= ROW()-ROW($K$2) <= no_output_rows
• L3（拖动说 L100，请参阅评论说明）= IF(K3,IF(COUNTIF($L$2:L2,L2)
• M3（拖动说 M100，请参阅注释说明）= IF(K3,IF(M2 < no_of_data_columns,M2+1,1),"-")
• N3（拖动说 N100，请参阅评论说明）= INDEX(row_header,L3)
• O3（拖动说 O100，请参阅评论说明）= INDEX(column_header,M3)
• P3（拖动说 P100，请参阅注释说明）= INDEX(data_matrix,L3,M3)
• K3 中的评论：可选：检查是否预期为否。已实现输出行数。不需要，如果仅准备此表，则限制为否。的输出行。
• L3 中的评论：目标：每个 RowIndex (1 .. no_of_data_rows) 必须重复 no_of_data_columns 次。这将为 row_header 值提供索引查找。在此示例中，每个 RowIndex (1 .. 3) 必须重复 4 次。算法：检查 RowIndex 已经发生了多少次。如果小于 no_of_data_columns 次，则继续使用该 RowIndex，否则增加 RowIndex。可选：检查是否预期没有。已实现输出行数。
• M3 中的注释：目标：每个 ColumnIndex (1 .. no_of_data_columns) 必须在一个循环中重复。这将为 column_header 值提供索引查找。在此示例中，每个 ColumnIndex (1 .. 4) 必须在一个循环中重复。算法：如果 ColumnIndex 超过 no_of_data_columns，则从 1 重新开始循环，否则增加 ColumnIndex。可选：检查是否预期没有。已实现输出行数。
• R4 中的注释：可选：使用 K 列进行错误处理，如 L 列和 M 列所示。检查是否查找值 IsBlank 以避免由于 data_matrix 中的空白输入而导致输出中不正确的“0”。