不同工作簿比较

无辣味水煮鱼

现有N个工作簿，“数据源”工作簿A列和B列对应有字母和数字，如果其他工作簿中的字母和“数据源”工作簿中字母相同，那么对应的数字为“数据源”工作簿中A列对应的数字。请查看附件。

蓝桥玄霜

1. Sub lqxs()
   
2.     Dim Arr, myPath$, myName$, wb As Workbook, Arr1
   
3.     Dim m&, funm$, i&, d
   
4.     Application.ScreenUpdating = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set wb = ThisWorkbook
   
7.     funm = wb.Name
   
8.     Sheet1.Activate
   
9.     Arr = [a1].CurrentRegion
   
10.     myPath = ThisWorkbook.Path & ""
    
11.     myName = Dir(myPath & "*.xls")
    
12.     Do While myName <> "" And myName <> funm
    
13.         With GetObject(myPath & myName)
    
14.             Arr1 = .Sheets(1).Range("A1").CurrentRegion
    
15.             .Close False
    
16.         End With
    
17.         For i = 1 To UBound(Arr1)
    
18.             d(Arr1(i, 1)) = Arr1(i, 2)
    
19.         Next
    
20.         For i = 1 To UBound(Arr)
    
21.             If d.exists(Arr(i, 1)) Then Cells(i, 2) = d(Arr(i, 1))
    
22.         Next
    
23.         myName = Dir
    
24.     Loop
    
25.     Application.ScreenUpdating = True
    
26. End Sub
    

复制代码

蓝桥玄霜

请见附件。

无辣味水煮鱼

谢谢大虾！

无辣味水煮鱼

蓝大侠，这个附件有点不给力啊，能否抽时间再看看？Thank you in advance.
另外，我自己尝试写了个，但是实现不了，能否帮忙看看？谢谢
Sub test()
Dim myPath$, myFile$, wb As Workbook, d As Object, arr, brr, i%, j%
Set d = CreateObject("Scripting.dictionary")
myPath = ThisWorkbook.Path & "\"
myFile = Dir(myPath & "*xls")
Application.ScreenUpdating = False
Do While myFile <> ""
If myFile <> ThisWorkbook.Name Then
    Set wb = GetObject(myPath & myFile)
    arr = ThisWorkbook.Sheets("Sheet1").Range("A1:B" & ThisWorkbook.Sheets("Sheet1").Range("A65536").End(xlUp).Row)
    brr = wb.Sheets("Sheet1").Range("A1:B" & wb.Sheets("Sheet1").Range("A65536").End(xlUp).Row)
    For i = 1 To UBound(arr)
        d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
    Next i
    For j = 1 To UBound(brr)
        If d.exists(brr(j, 1)) Then
            wb.Sheets("Sheet1").Cells(j, "B").Value = d(brr(j, 1))
       End If
    Next j
wb.Close False
End If
myFile = Dir
Loop
Application.ScreenUpdating = True


End Sub

zhaogang1960

短信收到，要求不清楚，N个工作簿却只上传了一个数据源，我的理解是罗列N-1个数据源和比较表格的A列数据都比，只写出相同的：

1. Sub Macro1()
   
2.     Dim cnn As Object, MyPath$, MyFile$, SQL$, m&, sh As Worksheet, s$
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ActiveSheet
   
5.     s = "[Excel 8.0;hdr=no;Database=" & ThisWorkbook.FullName & "].[" & sh.Name & "$a1:a" & [a65536].End(xlUp).Row & "]"
   
6.     sh.UsedRange.Offset(, 2).ClearContents
   
7.     Set cnn = CreateObject("adodb.connection")
   
8.     MyPath = ThisWorkbook.Path & ""
   
9.     MyFile = Dir(MyPath & "*.xls")
   
10.    
    
11.     With sh
    
12.         Do While Len(MyFile)
    
13.             If MyFile <> ThisWorkbook.Name Then
    
14.                 m = m + 2
    
15.                 If m = 2 Then
    
16.                     cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & MyPath & MyFile
    
17.                     SQL = "select '" & Split(MyFile, ".")(0) & "工作簿',a.f2 from [Sheet1$] a right join " & s & " b on a.f1=b.f1"
    
18.                 Else
    
19.                     SQL = "select '" & Split(MyFile, ".")(0) & "工作簿',a.f2 from [Excel 8.0;hdr=no;Database=" & MyPath & MyFile & "].[Sheet1$] a right join " & s & " b on a.f1=b.f1"
    
20.                 End If
    
21.                 .Cells(1, m).CopyFromRecordset cnn.Execute(SQL)
    
22.             End If
    
23.             MyFile = Dir
    
24.         Loop
    
25.     End With
    
26.     cnn.Close
    
27.     Set cnn = Nothing
    
28.     Application.ScreenUpdating = True
    
29. End Sub
    
30. 
    

复制代码

zhaogang1960

加了一个数据源2.xls作为比较，请看附件
比较.rar (20.86 KB, 下载次数: 29)

2012-10-6 22:15 上传

点击文件名下载附件

zhaogang1960

再加上比较表格中不存在的，放到比较表格数据的下方，每比较一个工作簿，会输出3列数据：工作簿、A列数据、B列数据

1. Sub Macro1()
   
2.     Dim cnn As Object, MyPath$, MyFile$, SQL$, m&, sh As Worksheet, s$
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ActiveSheet
   
5.     s = "[Excel 8.0;hdr=no;Database=" & ThisWorkbook.FullName & "].[" & sh.Name & "$a1:a" & [a65536].End(xlUp).Row & "]"
   
6.     sh.UsedRange.Offset(, 2).ClearContents
   
7.     Set cnn = CreateObject("adodb.connection")
   
8.     MyPath = ThisWorkbook.Path & ""
   
9.     MyFile = Dir(MyPath & "*.xls")
   
10.     m = -1
    
11.     With sh
    
12.         Do While Len(MyFile)
    
13.             If MyFile <> ThisWorkbook.Name Then
    
14.                 m = m + 3
    
15.                 If m = 2 Then
    
16.                     cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & MyPath & MyFile
    
17.                     SQL = "select '" & Split(MyFile, ".")(0) & "工作簿',a.* from [Sheet1$] a right join " & s & " b on a.f1=b.f1 union all " _
    
18.                         & "select '" & Split(MyFile, ".")(0) & "工作簿',a.* from [Sheet1$] a left join " & s & " b on a.f1=b.f1 where b.f1 is null"
    
19.                 Else
    
20.                     SQL = "select '" & Split(MyFile, ".")(0) & "工作簿',a.* from [Excel 8.0;hdr=no;Database=" & MyPath & MyFile & "].[Sheet1$] a right join " & s & " b on a.f1=b.f1 union all " _
    
21.                         & "select '" & Split(MyFile, ".")(0) & "工作簿',a.* from [Excel 8.0;hdr=no;Database=" & MyPath & MyFile & "].[Sheet1$] a left join " & s & " b on a.f1=b.f1 where b.f1 is null"
    
22.                 End If
    
23.                 .Cells(1, m).CopyFromRecordset cnn.Execute(SQL)
    
24.             End If
    
25.             MyFile = Dir
    
26.         Loop
    
27.     End With
    
28.     cnn.Close
    
29.     Set cnn = Nothing
    
30.     Application.ScreenUpdating = True
    
31. End Sub

复制代码

zhaogang1960

请看附件
比较2.rar (21.61 KB, 下载次数: 24)

2012-10-6 22:40 上传

点击文件名下载附件

无辣味水煮鱼

谢谢，强悍！