楼主
0Mouse |
Q：如何运用vba快速提取表1、表2的相同记录到表3呢？
示例：
表1记录：
表2记录：
提取至表3的相同记录：
A：可以采用数组+双字典解决，代码如下：- Sub 取同()
- Dim arr, brr, d1 As Object, d2 As Object, i%, j%
- arr = Sheet1.Range("A1").CurrentRegion
- brr = Sheet2.Range("A1").CurrentRegion
- Set d1 = CreateObject("scripting.dictionary")
- Set d2 = CreateObject("scripting.dictionary")
- For i = 1 To UBound(arr)
- d1(arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6)) = ""
- Next
- For j = 1 To UBound(brr)
- If d1.Exists(brr(j, 1) & brr(j, 2) & brr(j, 3) & brr(j, 4) & brr(j, 5) & brr(j, 6)) Then
- d2(j) = Application.Index(brr, j)
- End If
- Next
- Sheet3.Range("A1").Resize(d2.Count, 6) = Application.Transpose(Application.Transpose(d2.items))
- Set arr = Nothing
- Set brr = Nothing
- Set d1 = Nothing
- Set d2 = Nothing
- End Sub
示例附件：
 提取表1、表2相同记录到表3.rar
|
2楼
angel928 |
跟着小千 学习VBA。 |
3楼
亡者天下 |
过来学习一下 |
4楼
猴子 |
学习以下啊、、、 |
5楼
LOGO |
补充一个利用高级筛选的:- Sub 宏1()
- Sheet3.Cells.Clear
- Sheet1.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
- CriteriaRange:=Sheet2.Range("A1").CurrentRegion, _
- CopyToRange:=Sheet3.Range("a1"), Unique:=true
- End Sub
|
6楼
LOGO |
提取表1有而表2没有的数据:- Sub 表1有而表2没有的数据()
- Dim ar
- Sheet1.Copy , Worksheets(Worksheets.Count)
- arr = Sheet1.Range("A1").CurrentRegion
- Sheet1.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
- CriteriaRange:=Sheet2.Range("A1").CurrentRegion, _
- CopyToRange:=Worksheets(Worksheets.Count).Cells(1, UBound(arr, 2) + 2), Unique:=True
- Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, _
- CriteriaRange:=Cells(1, UBound(arr, 2) + 2).Range("A1").CurrentRegion, _
- Unique:=True
- Application.DisplayAlerts = False
- Range("A1").CurrentRegion.Offset(1, 0).Delete
- ActiveSheet.ShowAllData
- Cells(1, UBound(arr, 2) + 2).CurrentRegion.clear
- End Sub
|
7楼
LOGO |
提取表2有而表1没有的数据:- Sub 表2有而表1没有的数据()
- Dim arr
- Sheet2.Copy , Worksheets(Worksheets.Count)
- arr = Sheet2.Range("A1").CurrentRegion
- Sheet2.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
- CriteriaRange:=Sheet1.Range("A1").CurrentRegion, _
- CopyToRange:=Worksheets(Worksheets.Count).Cells(1, UBound(arr, 2) + 2), Unique:=True
- Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, _
- CriteriaRange:=Cells(1, UBound(arr, 2) + 2).Range("A1").CurrentRegion, _
- Unique:=True
- Application.DisplayAlerts = False
- Range("A1").CurrentRegion.Offset(1, 0).Delete
- ActiveSheet.ShowAllData
- Cells(1, UBound(arr, 2) + 2).CurrentRegion.clear
- End Sub
|
8楼
LOGO |
在一些书上看到的案例中:- Application.DisplayAlerts = False
与- Application.DisplayAlerts = True
都是成对出现的，但是实际测试中，好像不用加- Application.DisplayAlerts = True
这个警示框也会自动恢复. |
9楼
0Mouse |
这个倒是没有认真测试过，也许你测试的情况可以，难说也有不能恢复默认的情况，但反正加上是不会错的，也是一种良好的习惯。就好比一个变量在二次赋值的时候是否需要先清空的问题一样，整形变量不用，会直接替换，但string类型的变量在二次赋值前最好是先清空一下，否则结果可能会出错，我是碰到过，你可以留意看看。 |
10楼
LOGO |
有道理，那还是加上为好。谢谢！ |
11楼
tiger2003 |
学学，谢谢！ |