Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 5813|回复: 11

[已解决]请教如何用VBA语句把表2的数据匹配过来,不用公式

[复制链接]
发表于 2014-5-9 15:19 | 显示全部楼层 |阅读模式
本帖最后由 chensir 于 2014-5-9 16:54 编辑

请教如何用VBA语句把表2的数据匹配到表1里,不用公式
求助各位,谢谢
最佳答案
2014-5-9 15:38
供参考:
  1. Sub tt()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     With Sheet2
  4.         r2 = .[a65536].End(3).Row
  5.         For i = 2 To r2
  6.             Set d(.Cells(i, 1).Value) = .Cells(i, 1).Resize(1, 8)
  7.         Next
  8.     End With
  9.     With Sheet1
  10.         r1 = .[a65536].End(3).Row
  11.         For i = 2 To r1
  12.             If d.exists(.Cells(i, 1).Value) Then .Cells(i, 1).Resize(1, 8) = d(.Cells(i, 1).Value).Value
  13.         Next
  14.     End With
  15. End Sub
复制代码

工作簿2.zip

7.65 KB, 下载次数: 51

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2014-5-9 15:33 | 显示全部楼层
如果数据量小,不考虑速度
  1. Sub tt()
  2.     Dim x As Range
  3.     With Sheet1
  4.         r1 = .[a65536].End(3).Row
  5.         r2 = Sheet2.[a65536].End(3).Row
  6.         For i = 2 To r1
  7.             Set x = Sheet2.[a:a].Find(.Cells(i, 1), lookat:=xlWhole)
  8.             If Not x Is Nothing Then .Cells(i, 1).Resize(1, 8) = x.Resize(1, 8).Value
  9.         Next
  10.     End With
  11. End Sub
复制代码
回复

使用道具 举报

发表于 2014-5-9 15:38 | 显示全部楼层    本楼为最佳答案   
供参考:
  1. Sub tt()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     With Sheet2
  4.         r2 = .[a65536].End(3).Row
  5.         For i = 2 To r2
  6.             Set d(.Cells(i, 1).Value) = .Cells(i, 1).Resize(1, 8)
  7.         Next
  8.     End With
  9.     With Sheet1
  10.         r1 = .[a65536].End(3).Row
  11.         For i = 2 To r1
  12.             If d.exists(.Cells(i, 1).Value) Then .Cells(i, 1).Resize(1, 8) = d(.Cells(i, 1).Value).Value
  13.         Next
  14.     End With
  15. End Sub
复制代码
回复

使用道具 举报

发表于 2014-5-9 15:42 | 显示全部楼层
供参考
  1. Sub tt()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     arr1 = Sheet1.[a1].CurrentRegion
  4.     arr2 = Sheet2.[a1].CurrentRegion
  5.     For i = 2 To UBound(arr2)
  6.         d(arr2(i, 1)) = i
  7.     Next

  8.     For i = 2 To UBound(arr1)
  9.         If d.exists(arr1(i, 1)) Then
  10.             n = d(arr1(i, 1))
  11.             For j = 2 To UBound(arr2, 2)
  12.                 arr1(i, j) = arr2(n, j)
  13.             Next
  14.         End If
  15.     Next
  16.     Sheet1.[a1].CurrentRegion = arr1
  17. End Sub
复制代码
回复

使用道具 举报

发表于 2014-5-9 15:52 | 显示全部楼层
本帖最后由 qh8600 于 2014-5-9 15:53 编辑
  1. Sub dome()
  2.     Dim ar, br, cr, i As Integer, j As Integer, s As Integer, n As Integer
  3.     ar = Sheets("表1").Range("A1").CurrentRegion
  4.     br = Sheets("表2").Range("A1").CurrentRegion
  5.     ReDim cr(1 To UBound(ar), 1 To 7)
  6.     For i = 2 To UBound(ar)
  7.         n = n + 1
  8.         For s = 1 To UBound(br)
  9.             If ar(i, 1) = br(s, 1) Then
  10.                 For j = 1 To 7
  11.                     cr(n, j) = br(s, j + 1)
  12.                 Next j
  13.             End If
  14.         Next s
  15.     Next i
  16.     With Sheets("表1")
  17.         .Range("B2:H8").ClearContents
  18.         .Range("b2").Resize(n, 7) = cr
  19.     End With
  20. End Sub
复制代码
不会字典,只能数组循环
回复

使用道具 举报

发表于 2014-5-9 16:01 | 显示全部楼层
如果数据源、标题等固定,
如果只为完成赋值、排序,


Sub Click()
    With Sheet1
        .[a1:h8] = Sheet2.[a1:h8].Value
        .Range("a:a").Sort [a1], 2, Header:=xlYes
    End With
End Sub

回复

使用道具 举报

 楼主| 发表于 2014-5-9 16:08 | 显示全部楼层
还是有问题,只是行匹配了,表1列字段一变化就不对了
回复

使用道具 举报

 楼主| 发表于 2014-5-9 16:09 | 显示全部楼层
本帖最后由 chensir 于 2014-5-9 16:12 编辑
grf1973 发表于 2014-5-9 15:42
供参考

你好,还是有问题,只是行匹配了,表1列字段一变化就不对了

或者我表1中的字段只是表2字段的一部分,就不对了

回复

使用道具 举报

发表于 2014-5-9 16:45 | 显示全部楼层
chensir 发表于 2014-5-9 16:09
你好,还是有问题,只是行匹配了,表1列字段一变化就不对了

或者我表1中的字段只是表2字段的一部分,就 ...

要根据列字段自动匹配啊,那字典要麻烦一点。
  1. Sub tt()
  2. Set d = CreateObject("scripting.dictionary")
  3. arr1 = Sheet1.[a1].CurrentRegion
  4. arr2 = Sheet2.[a1].CurrentRegion
  5. For i = 2 To UBound(arr2)
  6. For j = 2 To UBound(arr2, 2)
  7. x = arr2(i, 1) & arr2(1, j)
  8. d(x) = arr2(i, j)
  9. Next
  10. Next

  11. For i = 2 To UBound(arr1)
  12. For j = 2 To UBound(arr1, 2)
  13. x = arr1(i, 1) & arr1(1, j)
  14. If d.exists(x) Then arr1(i, j) = d(x)
  15. Next
  16. Next
  17. Sheet1.[a1].CurrentRegion = arr1
  18. End Sub
复制代码
回复

使用道具 举报

发表于 2014-5-9 16:46 | 显示全部楼层
讨厌。回复模式下代码无格式。
  1. Sub tt()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     arr1 = Sheet1.[a1].CurrentRegion
  4.     arr2 = Sheet2.[a1].CurrentRegion
  5.     For i = 2 To UBound(arr2)
  6.         For j = 2 To UBound(arr2, 2)
  7.             x = arr2(i, 1) & arr2(1, j)
  8.             d(x) = arr2(i, j)
  9.         Next
  10.     Next

  11.     For i = 2 To UBound(arr1)
  12.         For j = 2 To UBound(arr1, 2)
  13.             x = arr1(i, 1) & arr1(1, j)
  14.             If d.exists(x) Then arr1(i, j) = d(x)
  15.         Next
  16.     Next
  17.     Sheet1.[a1].CurrentRegion = arr1
  18. End Sub
复制代码
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 10:37 , Processed in 0.639049 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表