Question

我有以下VBA代码：

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

此代码的简短版本如下：

1）设置应搜索的第一张纸和应附加结果的第二张纸（输出纸）。

2）在第一列搜索某个字符串＆＃34; Order＆＃34;并且一旦找到第二列中的值，将其放在输出表中去寻找＆＃34;项目＆＃34;一旦＆＃34;项目＆＃34;发现在Offset附近搜索该条目附近的各种项目。

3）重复，直到没有其他条目可以搜索。

我希望将这个内部范围集合到一个循环中，因为我需要从每行的0到m列，然后一直向下移动到n行，然后再向前移动并寻找一个新的＆＃34;订单＆＃34;条目。困难在于每个＆＃34;项目＆＃34;与＆＃34;订单相关联的条目＆＃34; entry具有与其关联的可变行数。有时我只需要在完成之前退出10，有时我需要下降50.一个潜在有用的属性是每个＆＃34; Order＆＃34;输入总是在＆＃34;项目＆＃34;下搜索的最后一行之后发生。 - 换句话说，循环再次开始的地方。

示例输入：

   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

我想要的主要是以下输出：

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

有没有人有一个有效的方法来做到这一点？谢谢！

Answer 1

这对我的样本数据起了作用：

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

添加额外的循环

1 个答案: