CODEWITHSUNDEEP
excelvba
Destiny L Bradley
Destiny L Bradley

Reputation: 23

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

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).

enter image description here

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.

enter image description here

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?

Upvotes: 0

Views: 105

Answers (2)

YasserKhalil
YasserKhalil

Reputation: 9538

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

Upvotes: 1

HTH
HTH

Reputation: 2031

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

Upvotes: 0

Related Questions