VBA: сжатие листа (несколько столбцов) до 2 столбцов на основе имени заголовка и значения столбца

Question

У меня есть рабочая книга, которая содержит несколько листов данных, которые я объединил. Я удалил некоторые ненужные листы и ячейки (которые заполнены цветом) и удалил пробелы (пример кода ниже). Теперь у меня есть один рабочий лист с датами в качестве заголовков и номерами элементов (длина столбца варьируется).

Мне нужно снова сконцентрироваться. Мне нужны два столбца, столбцы A и B, B для каждого номера элемента, извлеченного из листа, а столбец A должен быть именем заголовка столбца, из которого был извлечен номер элемента. количество столбцов будет увеличиваться со временем по мере добавления новых дат.

Я просто не знаю, откуда go отсюда ... Сценарий "Basi c", а затем "Я проверил качество, и он работает до этого момента.

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

Затем у меня появляется всплывающее окно для удаления определенных c цветных ячеек и заканчивается этим:

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

Я могу скопировать значения столбца после, после выше, к новому листу, но затем добавление значений заголовка на основе последней ячейки в этом столбце достигает моих ограничений VBA.

Я не вижу, что об этом уже спрашивали и отвечали ранее, любые идеи

Answer 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

Answer 2

вы могли бы использовать Dictionary объект

, предполагая, что вы хотите сжать данные на рабочем листе с именем "Сжатый" уже на месте

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