[已解决]如何查找不同的EXCEL表中的相同的数据

hadesqu

  请教各位大神，我现在想查找不同EXCEL中是否有相同的数据，如果有相同的数据就填入总表中，并将查找到的Excel 表的名字填到该数据上一行，因为数据比较多，所以数据和总表不在一个文件夹内，能不能再加个选择框体去选择文件夹啊？

最佳答案

月排行榜 / 总排行榜

grf1973

2015-4-3 16:58

1. Sub 比较()
   
2.     '** 使用FileDialog对象来选择文件夹
   
3.     Dim fd As FileDialog
   
4.     Dim myPath As String
   
5.     Set fd = Application.FileDialog(msoFileDialogFolderPicker)
   
6.     fd.InitialFileName = ThisWorkbook.Path & ""
   
7.     If fd.Show = -1 Then myPath = fd.SelectedItems(1)
   
8.     Set fd = Nothing
   
9.     If myPath <> "" Then  '如果选到
   
10.         Dim wb As Workbook
    
11.         Set fso = CreateObject("scripting.filesystemobject")
    
12.         Set ff = fso.getfolder(myPath)
    
13.         xrr = Sheet1.Range("a1:a" & [a65536].End(3).Row)     '当前工作A列数据
    
14.         c = 1
    
15.         For Each f In ff.Files      '打开所有文件
    
16.             Set wb = Workbooks.Open(f)
    
17.             xname = Split(wb.Name, ".")(0)   '工作表名
    
18.             Set d = CreateObject("scripting.dictionary")
    
19.             arr = wb.Worksheets(1).[a1].CurrentRegion
    
20.             For i = 1 To UBound(arr)       '打开工作表A列和B列相关联
    
21.                d(arr(i, 1)) = arr(i, 2)
    
22.             Next
    
23.             wb.Close False
    
24.             ReDim yrr(1 To UBound(xrr), 1 To 1): yrr(1, 1) = xname
    
25.             For i = 2 To UBound(xrr)
    
26.                yrr(i, 1) = d(xrr(i, 1))
    
27.             Next
    
28.             c = c + 1
    
29.             Sheet1.Cells(1, c).Resize(UBound(yrr), 1) = yrr
    
30.         Next
    
31.     End If
    
32. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

相同数据是什么意思？

hadesqu

grf1973 发表于 2015-4-3 16:13
相同数据是什么意思？

A列里的名称和总表名称一样就把其对应的B列中的数据导入总表

grf1973

1. Sub 比较()
   
2.     '** 使用FileDialog对象来选择文件夹
   
3.     Dim fd As FileDialog
   
4.     Dim myPath As String
   
5.     Set fd = Application.FileDialog(msoFileDialogFolderPicker)
   
6.     fd.InitialFileName = ThisWorkbook.Path & ""
   
7.     If fd.Show = -1 Then myPath = fd.SelectedItems(1)
   
8.     Set fd = Nothing
   
9.     If myPath <> "" Then  '如果选到
   
10.         Dim wb As Workbook
    
11.         Set fso = CreateObject("scripting.filesystemobject")
    
12.         Set ff = fso.getfolder(myPath)
    
13.         xrr = Sheet1.Range("a1:a" & [a65536].End(3).Row)     '当前工作A列数据
    
14.         c = 1
    
15.         For Each f In ff.Files      '打开所有文件
    
16.             Set wb = Workbooks.Open(f)
    
17.             xname = Split(wb.Name, ".")(0)   '工作表名
    
18.             Set d = CreateObject("scripting.dictionary")
    
19.             arr = wb.Worksheets(1).[a1].CurrentRegion
    
20.             For i = 1 To UBound(arr)       '打开工作表A列和B列相关联
    
21.                d(arr(i, 1)) = arr(i, 2)
    
22.             Next
    
23.             wb.Close False
    
24.             ReDim yrr(1 To UBound(xrr), 1 To 1): yrr(1, 1) = xname
    
25.             For i = 2 To UBound(xrr)
    
26.                yrr(i, 1) = d(xrr(i, 1))
    
27.             Next
    
28.             c = c + 1
    
29.             Sheet1.Cells(1, c).Resize(UBound(yrr), 1) = yrr
    
30.         Next
    
31.     End If
    
32. End Sub
    

复制代码

hadesqu

grf1973 发表于 2015-4-3 16:58

谢谢，的确好用，但是还是麻烦你下，能不能将查找到的数据从总表的C列开始放起啊，因为B列 我还有别的数据在放，麻烦你了~~谢谢~

grf1973

代码第14句改成  c=2

张雄友

grf1973 发表于 2015-4-3 21:00
代码第14句改成  c=2

不包括本工作簿怎么不行的？红色代码怎么用才对？

Sub 比较()
    '** 使用FileDialog对象来选择文件夹
    Dim fd As FileDialog
    Dim myPath As String
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    fd.InitialFileName = ThisWorkbook.Path & "\"
    If fd.Show = -1 Then myPath = fd.SelectedItems(1)
    Set fd = Nothing
    If myPath <> "" Then  '如果选到
    If myPath <> ThisWorkbook.Name Then
        Dim wb As Workbook
        Set fso = CreateObject("scripting.filesystemobject")
        Set ff = fso.getfolder(myPath)
        xrr = Sheet1.Range("a1:a" & [a65536].End(3).Row)     '当前工作A列数据
        c = 1
        For Each f In ff.Files      '打开所有文件
            Set wb = Workbooks.Open(f)
            xname = Split(wb.Name, ".")(0)   '工作表名
            Set d = CreateObject("scripting.dictionary")
            arr = wb.Worksheets(1).[a1].CurrentRegion
            For i = 1 To UBound(arr)       '打开工作表A列和B列相关联
               d(arr(i, 1)) = arr(i, 2)
            Next
            wb.Close False
            ReDim yrr(1 To UBound(xrr), 1 To 1): yrr(1, 1) = xname
            For i = 2 To UBound(xrr)
               yrr(i, 1) = d(xrr(i, 1))
            Next
            c = c + 1
            Sheet1.Cells(1, c).Resize(UBound(yrr), 1) = yrr
        Next
    End If
    End If
End Sub

grf1973

张雄友 发表于 2015-4-3 21:17
不包括本工作簿怎么不行的？红色代码怎么用才对？

Sub 比较()

搞混啦，mypath是路径，另一个是不带路径的文件名

张雄友

grf1973 发表于 2015-4-3 22:03
搞混啦，mypath是路径，另一个是不带路径的文件名

这样也不行。

Sub 比较()
    '** 使用FileDialog对象来选择文件夹
    Dim fd As FileDialog
    Dim myPath As String
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    fd.InitialFileName = ThisWorkbook.Path & "\"
    If fd.Show = -1 Then myPath = fd.SelectedItems(1)
    Set fd = Nothing
    If myPath <> "" Then '如果选到
        Dim wb As Workbook
        Set fso = CreateObject("scripting.filesystemobject")
        Set ff = fso.getfolder(myPath)
        xrr = Sheet1.Range("a1:a" & [a65536].End(3).Row)     '当前工作A列数据
        c = 1
        For Each f In ff.Files      '打开所有文件
            If f <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(f)
            xname = Split(wb.Name, ".")(0)   '工作表名
            Set d = CreateObject("scripting.dictionary")
            arr = wb.Worksheets(1).[a1].CurrentRegion
            For i = 1 To UBound(arr)       '打开工作表A列和B列相关联
               d(arr(i, 1)) = arr(i, 2)
            Next
            wb.Close False
            ReDim yrr(1 To UBound(xrr), 1 To 1): yrr(1, 1) = xname
            For i = 2 To UBound(xrr)
               yrr(i, 1) = d(xrr(i, 1))
            Next
            c = c + 1
            Sheet1.Cells(1, c).Resize(UBound(yrr), 1) = yrr
            End If
        Next
    End If

End Sub

张雄友

grf1973 发表于 2015-4-3 22:03
搞混啦，mypath是路径，另一个是不带路径的文件名

不包括本工作簿，是 怎么的？