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.

Tragamor · Accepted Answer · 2017-03-16 15:52:02Z

7

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

answered Mar 16, 2017 at 15:52

Tragamor

3,6893 gold badges18 silver badges33 bronze badges

Sign up to request clarification or add additional context in comments.

1 Comment

JuniorDev Over a year ago

Thank you very much. Much appreciated

user3598756 · Accepted Answer · 2017-03-16 16:40:56Z

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

answered Mar 16, 2017 at 16:40

user3598756

29.5k4 gold badges20 silver badges30 bronze badges

2 Comments

JuniorDev Over a year ago

Thank you very much. Much appreciated

user3598756 Over a year ago

As you might have guessed this code does all the process: from data in sheet1 column A to its writedown in Sheet2 columns A and B. Without writing anything else in Sheet1

SJR · Accepted Answer · 2017-03-16 15:31:38Z

1

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

answered Mar 16, 2017 at 15:31

SJR

23.1k6 gold badges21 silver badges26 bronze badges

1 Comment

JuniorDev Over a year ago

Thank you very much. Much apprciated

Jerry Lundgren · Accepted Answer · 2017-03-16 22:00:37Z

1

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

answered Mar 16, 2017 at 22:00

Jerry Lundgren

614 bronze badges

1 Comment

JuniorDev Over a year ago

Thank you very much, very helpful.

Collectives™ on Stack Overflow

Loop through rows and columns Excel Macro VBA

4 Answers 4

1 Comment

2 Comments

1 Comment

1 Comment

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

4 Answers 4

1 Comment

2 Comments

1 Comment

1 Comment

Your Answer

Sign up or log in

Post as a guest

Linked

Related