[已解决]【数据匹配】请老师帮我精简下，不用一个一个的CALL打开。

xm2012 · 发表于 2015-11-11 23:48

本帖最后由 xm2012 于 2015-11-12 12:55 编辑

Sub 匹配数据A()
Dim d, k, t, Arr, i&, Myr&, Brr
Set d = CreateObject("Scripting.Dictionary")
Arr = Sheet2.Range("A:M")
For i = 1 To UBound(Arr)
d(Arr(i, 1)) = Arr(i, 9)
Next
k = d.Keys
t = d.Items
Sheet2.Activate
Myr = [N65536].End(xlUp).Row
Brr = Range("N8:AA" & Myr)
For i = 1 To UBound(Brr)
Brr(i, 14) = d(Brr(i, 1))

Next
[T8].Resize(UBound(Brr), 1) = Application.Index(Brr, 0, 14)
Call 匹配数据B
End Sub
Sub 匹配数据B()
Dim d, k, t, Arr, i&, Myr&, Brr
Set d = CreateObject("Scripting.Dictionary")
Arr = Sheet2.Range("A:M")
For i = 1 To UBound(Arr)
d(Arr(i, 1)) = Arr(i, 7)
Next
k = d.Keys
t = d.Items
Sheet2.Activate
Myr = [N65536].End(xlUp).Row
Brr = Range("N8:AA" & Myr)
For i = 1 To UBound(Brr)
Brr(i, 14) = d(Brr(i, 1))

Next
[U8].Resize(UBound(Brr), 1) = Application.Index(Brr, 0, 14)
Call 匹配数据C
End Sub
Sub 匹配数据C()
Dim d, k, t, Arr, i&, Myr&, Brr
Set d = CreateObject("Scripting.Dictionary")
Arr = Sheet2.Range("A:M")
For i = 1 To UBound(Arr)
d(Arr(i, 1)) = Arr(i, 8)
Next
k = d.Keys
t = d.Items
Sheet2.Activate
Myr = [N65536].End(xlUp).Row
Brr = Range("N8:AA" & Myr)
For i = 1 To UBound(Brr)
Brr(i, 14) = d(Brr(i, 1))

Next
[V8].Resize(UBound(Brr), 1) = Application.Index(Brr, 0, 14)
End Sub
已上传附件，方便其他朋友学习！

前效果.rar (41.39 KB, 下载次数: 14)

xm2012 · 发表于 2015-11-12 08:55

老师们在不在！？帮我简化下咯！

青城山苦丁茶 · 发表于 2015-11-12 11:05

试试看对不
Sub 匹配数据A()
Dim d, k, t, Arr, i&, Myr&, Brr
Sheet2.Activate
Set d = CreateObject("Scripting.Dictionary")
Myr = [N65536].End(xlUp).Row
Arr = Range("A1:I" & Myr)
For i = 1 To UBound(Arr)
   d(Arr(i, 1)) = Arr(i, 9) & "|" & Arr(i, 7) & "|" & Arr(i, 8)
Next
Myr = [N65536].End(xlUp).Row
Brr = Range("N8:p" & Myr)
For i = 1 To UBound(Brr)
   atmp = Split(d(Brr(i, 1)), "|")
   Brr(i, 1) = atmp(0)
   Brr(i, 2) = atmp(1)
   Brr(i, 3) = atmp(2)
Next
[T8].Resize(UBound(Brr), 3) = Brr
End Sub

grf1973 · 发表于 2015-11-12 11:39

Sub 匹配数据()
Dim da, db, dc, k, t, Arr, i&, Myr&, Brr
Set da = CreateObject("Scripting.Dictionary")
Set db = CreateObject("Scripting.Dictionary")
Set dc = CreateObject("Scripting.Dictionary")
Arr = Sheet2.Range("A:M")
For i = 1 To UBound(Arr)
      da(Arr(i, 1)) = Arr(i, 9)
      db(Arr(i, 1)) = Arr(i, 7)
      dc(Arr(i, 1)) = Arr(i, 8)
Next
k = d.Keys
t = d.Items
Sheet2.Activate
Myr = [N65536].End(xlUp).Row
Brr = Range("N8:N" & Myr)
ReDim crr(1 To UBound(Brr), 1 To 3)    'T8开始三列
For i = 1 To UBound(Brr)
      crr(i, 1) = da(Brr(i, 1))       'T列
      crr(i, 2) = db(Brr(i, 1))       'U列
      crr(i, 3) = dc(Brr(i, 1))       'V列
Next
[T8].Resize(UBound(Brr), 3) = crr
End Sub

xm2012 · 发表于 2015-11-12 12:53

感谢老师的指导~！谢谢~

现在把附件加上，

青山导师的代码运行无报错。

grf1973 老师的运行报错！

grf1973 · 发表于 2015-11-12 14:19

把你原来的废语句删掉就好了。
k = d.Keys
t = d.Items

xm2012 · 发表于 2015-11-13 17:18

grf1973 发表于 2015-11-12 14:19
把你原来的废语句删掉就好了。
k = d.Keys
t = d.Items

谢谢~！！

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

[已解决]【数据匹配】请老师帮我精简下，不用一个一个的CALL打开。

评分