Adding Additional Loops

Question

I have the following VBA code:

Sub test()
    Dim w1 As Worksheet
    Dim w2 As Worksheet

    Dim k As Long

    Dim c As Range
    Dim d As Range
    Dim strFA As String

    Set w1 = Sheets("a")
    Set w2 = Sheets("b")

    w2.Cells.Clear
    k = 1

    With w1.Range("A:A")
        Set c = .Cells.Find("Order" After:=.Cells(.Cells.Count), lookat:=xlWhole)
        strFA = ""
        While Not c Is Nothing And strFA <> c.Address
            If strFA = "" Then strFA = c.Address
            If IsError(Application.Match(c.Offset(1, 0).value, w2.Range("A:A"), False)) Then
                Set d = .Cells.Find("Item", c, , xlWhole)
            w2.Range("A" & k).value = c.Offset(0, 1).value
            w2.Range("B" & k).value = d.Offset(0, 2).value
            w2.Range("C" & k).value = d.Offset(0, 3).value
            w2.Range("D" & k).value = d.Offset(0, 4).value
            w2.Range("E" & k).value = d.Offset(0, 5).value
            w2.Range("F" & k).value = d.Offset(1, 1).value
            w2.Range("G" & k).value = d.Offset(1, 2).value
            w2.Range("H" & k).value = d.Offset(1, 3).value
            w2.Range("I" & k).value = d.Offset(1, 4).value
            w2.Range("J" & k).value = d.Offset(1, 5).value
                k = k + 1
            End If
            Set c = .Cells.Find("Item", After:=c, lookat:=xlWhole)
        Wend
    End With

End Sub

The short version of what this code does is as follows:

1) Set the first sheet that should be searched and the second sheet (output sheet) that the results should be appended to.

2) Search the first column for a certain string "Order" and once found take the value in the second column, place it in the output sheet go look for "Item" Once "Item" is found search for a variety of items near that entry with Offset.

3) Repeat until there are no more entries to search through.

I'm looking to consolidate this inner set of ranges into a loop, since I will need to go from 0 to m columns for every row, and then down all the way to n rows before moving back and looking for a new "Order" entry. The difficulty is that each "Item" entry associated with an "Order" entry has a variable number of rows in turn associated with it. Sometimes I will only need to go down 10 before I'm done and other times I'll need to go down 50. A potentially useful property is that every "Order" entry always occurs after the last row being searched under "Item" - in other words that's where the cycle begins again.

Sample Input:

   Col1          Col2       Col3

    Order1
    Something
    Else
    More Text

    More Text

    Other Text



    Numbers
    Numbers
    Text

    Item
    A             Item1       23
    B             Item2       24
    C             Item3       57
    C             Item4       89 
    Order2
    Something
    Else
    More Text

    More Text

    Other Text



    Numbers
    Numbers
    Text






    Item
    A              Item5       145
    C              Item6        4
    A              Item7        42

What I'd like is essentially the following output:

Col1   Col2  Col3     Col4
Order1  A     Item1    23
Order1  B     Item3    24
Order1  C     Item4    57
Order1  C     Item5    89 
Order2  A     Item2    145
Order2  C     Item3    4
Order2  A     Item5    42

Does anyone have an effective way to do this? Thanks!

I did something similar yesterday that you might be able to adapt? stackoverflow.com/questions/31418075/… You only need the second half since your column A is already filled. — findwindow
– findwindow, Commented Jul 17, 2015 at 20:53
@TimWilliams Edited with a somewhat messy but accurate example. As you might notice the spacing is unreliable and it's never clear when 'Item' will occur or how many items will occur within it. The layout of the document provided is largely why I'm doing this. — 114
– 114, Commented Jul 20, 2015 at 21:27

Tim Williams · Accepted Answer · 2015-07-30 17:00:53Z

2

This worked for me on your sample data:

Sub ExtractOrderItems()
    Const MAX_BLANK As Long = 100
    Dim c As Range, numBlank As Long, d As Range
    Dim sOrder As String, tmp, inItems As Boolean

    Set c = ActiveSheet.Range("A1")
    Set d = ThisWorkbook.Sheets("Items").Range("A2")
    'If putting the items in a different workbook from the one
    '  containing the code you'd use:
    'Set d = Workbooks("ListBook.xlsx").Sheets("Items").Range("A2")

    numBlank = 0
    sOrder = ""

    'loop until we've run through MAX_BLANK empty cells....
    Do While numBlank < MAX_BLANK
        tmp = c.Value
        If Len(tmp) > 0 Then

            If tmp Like "Order*" Then
                sOrder = tmp
                inItems = False
            Else
                If Trim(c.Value) = "Item" Then
                    inItems = True
                Else
                    If inItems Then
                        d.Resize(1, 4).Value = Array(sOrder, c.Value, c.Offset(0, 1).Value, _
                                                  c.Offset(0, 2).Value)
                        Set d = d.Offset(1, 0)
                    End If
                End If
            End If

            numBlank = 0
        Else
            numBlank = numBlank + 1
        End If
        Set c = c.Offset(1, 0)
    Loop

End Sub

edited Jul 30, 2015 at 17:00

answered Jul 24, 2015 at 23:04

Tim Williams

169k8 gold badges104 silver badges143 bronze badges

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

7 Comments

114 Over a year ago

I'm getting an error "subscript out of range" on the line 'Set d'. I've changed Items to the proper sheet name, but still no luck. Is there maybe a simple fix for this?

Tim Williams Over a year ago

ThisWorkbook is the one containing the VBA code: if that's not the parent of the destination sheet then you'll need to adjust that line.

114 Over a year ago

Thanks, that fixed it. Unfortunately nothing shows up when I try to walk through the code though (that is, the loop iterates but cells are left blank). I'll try to debug further.

Tim Williams Over a year ago

Are you starting with the "input" sheet as the active sheet?

114 Over a year ago

Thanks so much, I was, that was silly of me, it works well now. One final question: If I did want to run this through PERSONAL.XLSB how would I do that? That was where I was running it and getting the first error before.

|

Collectives™ on Stack Overflow

Adding Additional Loops

1 Answer 1

7 Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

7 Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related