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

Answer 3

Here is one approach

Sub x()

Dim r As Long, c As Long

Application.ScreenUpdating = False

With Sheets(1)
    For r = 1 To .Range("B" & Rows.Count).End(xlUp).Row
        c = .Cells(r, Columns.Count).End(xlToLeft).Column - 2
        .Cells(r, 2).Copy Sheets(2).Range("A" & Rows.Count).End(xlUp)(2).Resize(c)
        .Cells(r, 3).Resize(, c).Copy
        Sheets(2).Range("B" & Rows.Count).End(xlUp)(2).PasteSpecial Transpose:=True
    Next r
End With

Application.ScreenUpdating = True

End Sub

Answer 4

It's already marked as answered, but i found this question interesting. So, here is my contribution. This code doesn't need the initial split into multiple columns, just the one column with the comma separated data.

Dim rng As Range
Dim x As Variant
Dim i As Long
Dim offs As Long

offs = 1

Sheet2.Range("A1").Value = "Order Number"
Sheet2.Range("B1").Value = "Part Number"

For Each rng In Sheet1.Range("A:A")

    If Trim(rng.Value) = "" Then End

    x = Split(rng.Text, ",")

    For i = 1 To UBound(x)

        Sheet2.Range("A1").Offset(offs).Value = x(0)
        Sheet2.Range("B1").Offset(offs).Value = x(i)
        offs = offs + 1

    Next i

Next rng