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

lzxi · 发表于 2021-1-1 10:18

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

3190496160 · 发表于 2021-1-1 10:51

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 · 发表于 2021-1-1 10:53

3190496160 · 发表于 2021-1-1 10:54

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

lzxi · 发表于 2021-1-1 16:31

运行错误

lzxi · 发表于 2021-1-1 17:14

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

		自动登录	找回密码
密码			免费注册