求大神帮我修改一下替代料的查找语句，让他循环向下查找替代料到没有

18883201485

Sub 制作站位表()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim F, i, n, ar, arr, brr(1 To 5000, 1 To 8), wb As Workbook, rng As Range, d As Object, sht As Worksheet
    Set d = CreateObject("scripting.dictionary")
    F = Application.GetOpenFilename("导入BOM,*.xlsx;*.xls", MultiSelect:=True)
    Set wb = Workbooks.Open(F(1))
    ar = ActiveSheet.UsedRange
    wb.Close False
    F = Application.GetOpenFilename("导入站位表文件,*.csv", MultiSelect:=True)
    Set wb = Workbooks.Open(F(1))
    arr = ActiveSheet.UsedRange
    wb.Close False
    For i = 7 To UBound(arr) '机器名
        If arr(i, 1) <> "" Then d(Val(arr(i, 1))) = ""
    Next
    For Each sht In Sheets
        If sht.Name <> "站位表工具" Then sht.Delete
    Next
    For K = 0 To d.Count - 1
        For i = 7 To UBound(arr)
            If arr(i, 1) = d.keys()(K) And arr(i, 3) <> "2" And arr(i, 6) <> "" Then
                n = n + 1
                brr(n, 1) = n '序号
                If arr(i, 5) <> "" Then
                    brr(n, 2) = Right(arr(i, 4), 2) & "-" & arr(i, 5) '栈位号
                Else
                    brr(n, 2) = Right(arr(i, 4), 2) '栈位号
                End If
                brr(n, 3) = Left(arr(i, 6), 10) '物料编码
                brr(n, 5) = arr(i, 8) '飞达规格
                If arr(i, 12) <> "" Then
                    brr(n, 8) = arr(i, 12)  '位号
                    brr(n, 7) = UBound(Split(arr(i, 12), ",")) + 1 '用量
                End If
                If arr(i, 13) <> "" Then
                    brr(n, 8) = arr(i, 13)  '位号
                    brr(n, 7) = UBound(Split(arr(i, 13), ",")) + 1 '用量
                End If
                For r = 8 To UBound(ar)
                    If ar(r, 2) = brr(n, 3) Then
                        brr(n, 4) = ar(r, 5) '元件名称
                        If ar(r, 11) <> "" Then '判断是否主料
                            brr(n, 6) = "Y" '是主料

                                x = r
                            If ar(x + 1, 11) = "" And ar(x + 1, 2) <> "" Then '查找替代料
                               x = x + 1
                               n = n + 1
                               brr(n, 1) = n '序号
                               brr(n, 2) = brr(n - 1, 2) '栈位号
                               brr(n, 3) = ar(x, 2) '物料编码
                               brr(n, 4) = ar(x, 5) '替代料元件名称
                               brr(n, 5) = brr(n - 1, 5) '替代料飞达规格
                               brr(n, 6) = "N" '是替代料
                               brr(n, 7) = brr(n - 1, 7) '替代料用量
                               brr(n, 8) = brr(n - 1, 8) '位号
                            End If

                        Else
                            brr(n, 6) = "N"

                        End If


                      End If
                   Next
            End If
        Next
        Rows("6:5000").Delete
        [A6].Resize(UBound(brr), 8) = brr
        n = 0: Erase brr
        '        Range("a6:h" & [a65536].End(3).Row).HorizontalAlignment = Excel.xlCenter '左右居中
        '        Range("a6:h" & [a65536].End(3).Row).VerticalAlignment = xlCenter '上下居中
        Range("a6:h" & [a65536].End(3).Row).Borders.LineStyle = xlContinuous '添加边框
        Sheets("站位表工具").Copy after:=Sheets(Sheets.Count)
        ActiveSheet.Shapes.Range(Array("Button 1")).Delete
        ActiveSheet.Name = "机台" & d.keys()(K) & "-TAB1"

    Next
    MsgBox "站位表制作完成！", 48, "温馨提示"
End Sub

18883201485

压缩包里面有素材文件，一份BOM、 一份机台导出的原始站位表  、一份我修改残缺不全的工具。

3190496160

具体描述清楚你的需求，让别人看代码帮你改代码似乎是不可能的

18883201485

3190496160 发表于 2023-3-24 11:24
具体描述清楚你的需求，让别人看代码帮你改代码似乎是不可能的

我自己已经搞定了