按条件跨表合并

杨钊

按A1，B1，C1，D1条件在多个工作薄中查找，如果符合条件就把整列数据复制到这个表中。条件不止这3个，最好可以随时修改的.表格也不止4个，可能有十几个。

杨钊

求大神指点一下

dsmch

1. Sub dsmch()
   
2. Dim mypath$, arr, brr, j%
   
3. Set sht = ThisWorkbook.Sheets(1)
   
4. sht.[a2:f60000].Clear
   
5. arr = sht.Range("a1").CurrentRegion
   
6. mypath = ThisWorkbook.Path & ""
   
7. wj = Dir(mypath & "*.xls*")
   
8. Do While wj <> ""
   
9.     If wj <> ThisWorkbook.Name Then
   
10.        With GetObject(mypath & wj)
    
11.             brr = .Sheets(1).Range("a1").CurrentRegion
    
12.             For j = 1 To UBound(arr, 2)
    
13.                 Set Rng = .Sheets(1).Rows(1).Find(arr(1, j))
    
14.                 If Not Rng Is Nothing Then
    
15.                     .Sheets(1).Cells(2, Rng.Column).Resize(UBound(brr) - 1).Copy sht.Cells(60000, j).End(xlUp).Offset(1, 0)
    
16.                 End If
    
17.             Next
    
18.             .Close 0
    
19.        End With
    
20.     End If
    
21.     wj = Dir
    
22. Loop
    
23. End Sub

复制代码

杨钊

dsmch 发表于 2018-12-14 16:15

不行啊，运行后，那几个表的内容没有复制到汇总表来

dsmch

系统原因，修改第六行代码如下：
mypath = ThisWorkbook.Path & "\"

杨钊

dsmch 发表于 2018-12-14 21:32
系统原因
mypath = ThisWorkbook.Path & "\"

加这句进去吗