VBA: Condense worksheet (multiple cols) to 2 columns based on header name and column value - excel

Question

I have a workbook that contains several sheets of data that I have combined. I removed some unnecessary sheets and cells (that are colour filled) and removed blanks (code sample below). I now have one work sheet with dates as headers and item numbers (col length vary).
I need to condense this again. I need two columns, columns A and B, B for every item number pulled back from the sheet and the Col A needs to be the header name of the column the item number was pulled from. The amount of columns will extend over time as more dates are added.
I just don't know where to go from here... The script is basic 'and then' I have quality checked it and it works up to this point.
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
I then have a box pop up to delete specific coloured cells and end with this:
Columns("A:MK").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
I can copy column values over, after the above, to a new sheet but then adding header values based on the last cell in that column reaches my limitations of VBA.
I can't see that this has been asked and answered previously, any ideas?

Answer 1

Try this code
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

you could use Dictionary object
assuming you want to condense data in a worksheet named "Condensed" already in place
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