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

【问题标题】：VBA: Condense worksheet (multiple cols) to 2 columns based on header name and column valueVBA：根据标题名称和列值将工作表（多列）压缩为 2 列
【发布时间】：2020-04-08 07:33:07
【问题描述】：

我有一个工作簿，其中包含我合并的多张数据表。我删除了一些不必要的表格和单元格（已填充颜色）并删除了空白（下面的代码示例）。我现在有一张工作表，其中日期作为标题和项目编号（列长度不同）。

我需要再次浓缩。 对于从工作表中拉回的每个项目编号，我需要两列，A 列和 B 列，B 列需要是从中提取项目编号的列的标题名称。 随着日期的增加，列的数量会随着时间的推移而增加。

我只是不知道从哪里开始......脚本是基本的'然后'我已经对其进行了质量检查，并且到目前为止它仍然有效。

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

然后我会弹出一个框来删除特定颜色的单元格并以此结束：

Columns("A:MK").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp

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

我看不到以前有人问过并回答过这个问题，有什么想法吗？

【问题讨论】：

标签： excel vba

【解决方案1】：

试试这个代码

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

【讨论】：

这是正确的，运行了一些质量检查，计数都很好！非常感谢！

【解决方案2】：

你可以使用Dictionary对象

假设您想在一个名为“Condensed”的工作表中压缩数据

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

【讨论】：