求助，将综合表的部分数据提取到供应商窗体中

lzxi

祝：论坛中所有人新年快乐，平安吉祥
求助各位老师：将综合表的部分数据提取到供应商窗体中，设置一个提取按钮的VBA，还请多多指教。

3190496160

Sub 提取()
Dim d As Object, dc As Object
Dim ar As Variant
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("记录")
    .Range("b3:b14") = Empty
    .Range("d3:d14") = Empty
    ar = .Range("a3:d14")
    For j = 1 To UBound(ar, 2) Step 2
        For i = 1 To UBound(ar)
            If Trim(ar(i, j)) <> "" Then
                d(Trim(ar(i, j))) = i
                dc(Trim(ar(i, j))) = j
            End If
        Next i
    Next j
    f = Dir(ThisWorkbook.Path & "\综合录入.xls*")
    If f = "" Then MsgBox "找不到综合录入文件！": Exit Sub
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, 0)
    With wb.Worksheets("录入")
        br = .Range("a3:f13")
    End With
    wb.Close False
    For j = 1 To UBound(br, 2) Step 2
        For i = 1 To UBound(br)
            If Trim(br(i, j)) <> "" Then
                n = d(Trim(br(i, j)))
                m = dc(Trim(br(i, j)))
                If n <> "" And m <> "" Then
                    ar(n, m + 1) = br(i, j + 1)
                End If
            End If
        Next i
    Next j
    .Range("a3:d14") = ar
End With
MsgBox "ok!"
End Sub

3190496160

3190496160

例表.rar (82.5 KB, 下载次数: 11)

2021-1-1 10:54 上传

点击文件名下载附件

lzxi

运行错误

lzxi

可以运行时自动关闭综合录入，否则就是截图