多文件夹多工作簿多工作表查询

Leon01314

这个是简单的BOM查询表，请看附件。

查询表格放在2017年这个文件夹下面， 2017年文件夹下面还有子文件夹，例如2017年1月，2017年2月......
各个子文件夹下面存放的是EXCEL 工作簿，命名为1-1，1-2，1-3，2-1，2-2，2-3，2-4这种格式。
每个工作簿下面有多个工作表，最多35个，每个工作表为一个BOM，工作表命名大多是SHEET1，SHEET2这种，但是也有例外的。
每个工作表的D1单元格里面包含了产品料号，示例里面的料号只是为了方便区分，实际料号还包含字母和符号，并且和日期无关联。

在查询表中根据输入的料号，遍历所有文件夹下面的各个工作簿，然后找到包含料号的工作表，将A：D列信息复制到查询表里。

论坛上有个贴子和我的情况类似，初学，研究半天没搞懂，请高手帮忙用VBA代码实现，谢谢。
http://club.excelhome.net/thread-781055-7-1.html

kzg2013

Sub QUERY()
Dim AR As Object
Dim K, K1 As Long
Dim FSO, FD, SFD, FL As Object
Dim S As String
Application.DisplayAlerts = False
S = ActiveWorkbook.Path
R1 = ActiveSheet.Range("A1048576").End(xlUp).Row

If R1 > 1 Then
  ActiveSheet.Range("A2:D" & R1).Clear

End If

Set FSO = CreateObject("SCRIPTING.FILESYSTEMOBJECT")
Set FD = FSO.GETFOLDER(S)
     For Each SFD In FD.SUBFOLDERS
               For Each FL In SFD.Files
                         If UCase(FSO.GETEXTENSIONNAME(FL)) = "XLS" Or UCase(FSO.GETEXTENSIONNAME(FL)) = "XLSX" Then
                                  Set WB = GetObject(FL)
                                   For K = 1 To WB.Sheets.Count
                                        R = WB.Sheets(K).Range("A1048576").End(xlUp).Row
                                                  If WB.Sheets(K).Cells(1, "D") Like "*" & ActiveSheet.Cells(1, "C") & "*" Then
                                                      Set AR = WB.Sheets(K).Range("A2:D" & R)
                                                           ActiveSheet.Cells(2, "A").Resize(R - 1, 4) = AR()

                                                           WB.Close
                                                           With ActiveSheet.Range("A2:D" & Range("A1048576").End(xlUp).Row)
                                                           .Borders.LineStyle = xlContinuous
                                                           .Cells.HorizontalAlignment = xlCenter
                                                           End With
                                                           MsgBox "OK"
                                                            Application.DisplayAlerts = True
                                                           End '假设料号不重复，只在一张表中，若有重复，要一代码即可
                                                   End If
                                         Next K
                         End If
                           WB.Close
                        Set WB = Nothing
                       Next FL
  Next SFD

End Sub

kzg2013

试下是否可以>>>>>>>>>>>>

Leon01314

kzg2013 发表于 2017-2-22 23:13
Sub QUERY()
Dim AR As Object
Dim K, K1 As Long

非常感谢，代码可用，能不能将原来的格式也复制过来呀，比如填充颜色。

kzg2013

Leon01314 发表于 2017-2-23 19:04
非常感谢，代码可用，能不能将原来的格式也复制过来呀，比如填充颜色。

Sub QUERY()
Dim AR As Object
Dim K, K1 As Long
Dim FSO, FD, SFD, FL As Object
Dim S As String
Application.DisplayAlerts = False
S = ActiveWorkbook.Path
R1 = ActiveSheet.Range("A1048576").End(xlUp).Row

If R1 > 1 Then
  ActiveSheet.Range("A2:D" & R1).Clear
  
End If

Set FSO = CreateObject("SCRIPTING.FILESYSTEMOBJECT")
Set FD = FSO.GETFOLDER(S)
     For Each SFD In FD.SUBFOLDERS
               For Each FL In SFD.Files
                         If UCase(FSO.GETEXTENSIONNAME(FL)) = "XLS" Or UCase(FSO.GETEXTENSIONNAME(FL)) = "XLSX" Then
                                  Set WB = GetObject(FL)
                                   For K = 1 To WB.Sheets.Count
                                        R = WB.Sheets(K).Range("A1048576").End(xlUp).Row
                                                  If WB.Sheets(K).Cells(1, "D") Like "*" & ActiveSheet.Cells(1, "C") & "*" Then
                                                      WB.Sheets(K).Range("A2:D" & R).Copy ActiveSheet.Range("A2")
                                                           
                                                           WB.Close
                                                           With ActiveSheet.Range("A2:D" & Range("A1048576").End(xlUp).Row)
                                                           .Borders.LineStyle = xlContinuous
                                                           .Cells.HorizontalAlignment = xlCenter
                                                           End With
                                                           MsgBox "OK"
                                                            Application.DisplayAlerts = True
                                                           End '假设料号不重复，只在一张表中，若有重复，要一代码即可
                                                   End If
                                         Next K
                         End If
                           WB.Close
                        Set WB = Nothing
                       Next FL
  Next SFD

End Sub

jjmysjg

留下记号， 试试

Leon01314

这段代码速度不够快，现在才3月份，只有3个文件夹，每个文件夹下面有40多个工作薄，每个工作薄有10~40个工作表，实际运行起来需要10~40秒，请高手看下如何优化。

microyip

参考一下案例http://club.excelhome.net/thread-1332333-2-1.html，我写的一个代码

microyip

参考另一个案例的代码

Leon01314

microyip 发表于 2017-3-7 08:50
参考一下案例http://club.excelhome.net/thread-1332333-2-1.html，我写的一个代码

怎么报错了呀