Loop through rows and columns Excel Macro VBA

Question

I have a column in an Excel sheet containing data in this format: aaa,bbbb,ccc,dd,eeee,... each String is separated by a comma ","

I have created macro which splits the data in the column A and each String is separately inserted in a new cell for each row as shown in the screenshot.

Now I want to count how many used cells after the column B and according to that number repeat the value in the column B in a separate row and add to each row the next value in column C, D, E,...

At the end, the sheet 2 will look like this:

I have created a solution :

For i = 1 To 3

ActiveWorkbook.Sheets(2).Cells(i, 1).Value = ActiveWorkbook.Sheets(1).Range("B1").Value
ActiveWorkbook.Sheets(2).Cells(i, 2).Value = ActiveWorkbook.Sheets(1).Cells(1, i + 2).Value

Next i

But it works only when the column A has only one row. I have tried with different logic using Loops but it still doesn't get me the right result. I have hundreds of rows and it would be time consuming to do it manually. Any suggestion please. Thank you very much.

Answer 1

Sub ExtractParts()
    Dim wsSrc As Worksheet: Set wsSrc = Worksheets("Sheet1")
    Dim wsDest As Worksheet: Set wsDest = Worksheets("Sheet2")
    Dim LastRow As Long: LastRow = wsSrc.UsedRange.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim LastCol As Long: LastCol = wsSrc.UsedRange.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Dim i As Long, j As Long, RowCounter As Long: RowCounter = 2

    With wsDest
        .Cells(1, 1) = "Order Number"
        .Cells(1, 2) = "Part Number"
        For i = 1 To LastRow
            For j = 3 To LastCol
                If wsSrc.Cells(i, j) <> "" Then
                    .Cells(RowCounter, 1) = wsSrc.Cells(i, 2)
                    .Cells(RowCounter, 2) = wsSrc.Cells(i, j)
                    RowCounter = RowCounter + 1
                End If
            Next j
        Next i
    End With
End Sub

Answer 2

you could use a Dictionary approach

Sub main()
    Dim cell As Range
    Dim var As Variant

    With CreateObject("Scripting.Dictionary") '<--| instantiate a 'Dictionary' object
        For Each cell In Worksheets("Sheet1").Range("A1", Worksheets("Sheet1").cells(Worksheets("Sheet1").Rows.Count, 1).End(xlUp)) '<-- loop through "Sheet1" column A cells from row 1 down to the last not empty one
            var = Split(cell.Value, ",") '<--| store current cell content into an array, whose first element will be the 'key' of the dictionary
            .item(var(0)) = Split(Replace(cell.Value, var(0) & ",", "", , 1), ",") '<--| update current 'key' dictionary item with the array of "remaining" values
        Next
        For Each var In .Keys '<--| loop through dictionary keys
            Set cell = Worksheets("Sheet2").cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(.item(var)) + 1) '<--| set "Sheet2" range to start writing the current key values from
            cell.Value = var '<--| write key
            cell.Offset(, 1).Value = Application.Transpose(.item(var)) '<--| write current key values
        Next
    End With '<--| release 'Dictionary' object
End Sub