Excel VBA：根据标题名和列值将工作表（多列）压缩为2列

我有一个工作簿，其中包含我组合的几张数据表。我删除了一些不必要的表和单元格，这些表和单元格是彩色的，并删除了下面的空白代码示例。我现在有一个工作表，上面有日期，标题和项目编号以及长度各不相同

我需要再浓缩一下。我需要两列，A列和B列，B列用于从工作表中提取的每个项目编号，A列需要是从中提取项目编号的列的标题名称。随着添加更多日期，列的数量将随时间延长

我只是不知道从这里到哪里去。。。该脚本是基本的，然后我检查了它的质量，它工作到这一点

Worksheets.Add Sheets(1)
ActiveSheet.Name = "Combined"

For i = 2 To Sheets.Count
        Set xRg = Sheets(1).UsedRange
        If i > 2 Then
            Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
        End If
        Sheets(i).Activate
        ActiveSheet.UsedRange.Copy xRg
    Next i

Sheets("Data").Delete

For Each ws In Worksheets
If ws.Name <> "Combined" Then
ws.Visible = xlSheetHidden
End If
Next ws

我可以在上述操作之后将列值复制到新工作表中，但基于该列中的最后一个单元格添加标题值达到了我的VBA限制

我看不出之前有人问过和回答过这个问题，有什么想法吗？

您可以使用Dictionary object

假设您要在名为Condented的工作表中压缩数据，该工作表已就位

Sub Condense()
    Dim cel As Range
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    With Worksheets("Combined")
        For Each cel In .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft))
            dict.Add cel.Value, .Range(cel.Offset(1), cel.End(xlDown)).Value
        Next
    End With

    Dim key As Variant
    With Worksheets("Condensed")
        For Each key In dict.keys
            With .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(dict(key)))
                .Value = key
                .Offset(, 1) = dict(key)
            End With
        Next
    End With

End Sub

试试这个代码

Sub Test()
Dim a, ws As Worksheet, sh As Worksheet, i As Long, j As Long, k As Long

Set ws = ThisWorkbook.Worksheets("Combined")
Set sh = ThisWorkbook.Worksheets("Condensed")
a = ws.Range("A1").CurrentRegion.Value
ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 2)

For j = LBound(a, 2) To UBound(a, 2)
    For i = 2 To UBound(a)
        k = k + 1
        b(k, 1) = a(1, j)
        b(k, 2) = a(i, j)
    Next i
Next j

With sh.Range("A1")
    .Resize(1, 2).Value = Array("Header1", "Header2")
    .Offset(1).Resize(k, UBound(b, 2)).Value = b
End With
End Sub

---

这是现场，进行了一些质量检查，计数都很准确！非常感谢！

Sub Test()
Dim a, ws As Worksheet, sh As Worksheet, i As Long, j As Long, k As Long

Set ws = ThisWorkbook.Worksheets("Combined")
Set sh = ThisWorkbook.Worksheets("Condensed")
a = ws.Range("A1").CurrentRegion.Value
ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 2)

For j = LBound(a, 2) To UBound(a, 2)
    For i = 2 To UBound(a)
        k = k + 1
        b(k, 1) = a(1, j)
        b(k, 2) = a(i, j)
    Next i
Next j

With sh.Range("A1")
    .Resize(1, 2).Value = Array("Header1", "Header2")
    .Offset(1).Resize(k, UBound(b, 2)).Value = b
End With
End Sub