多工作簿数据汇总指定条件的数据

microyip · 发表于 2017-3-7 08:42

Sub 刷新资料()
Dim vDir As Variant, nDir As Integer
Dim vFile As Variant, nFile As Integer
Dim vFill As Variant
Dim nCol As Integer
Application.ScreenUpdating = False
ReDim vDir(1 To 1)
vDir(1) = ThisWorkbook.Path
获取文件夹 vDir, 1
ReDim vFile(1 To 1)
For nDir = 2 To UBound(vDir)
获取文件名 vFile, vDir(nDir)
Next
If vFile(1) <> "" Then
ReDim vFill(1 To 3, 1 To 1)
For nFile = 1 To UBound(vFile)
With Workbooks.Open(vFile(nFile))
vDir = .Sheets(1).UsedRange.Value
.Close False
End With
For nDir = 2 To UBound(vDir)
If vDir(nDir, 3) = "C店" Then
nFill = nFill + 1
ReDim Preserve vFill(1 To 3, 1 To nFill)
For nCol = 1 To 3
vFill(nCol, nFill) = vDir(nDir, nCol)
Next
End If
Next
Next
With Sheets("sheet1")
.UsedRange.Offset(1).ClearContents
.[A2].Resize(nFill, 3) = Application.WorksheetFunction.Transpose(vFill)
End With
End If
Application.ScreenUpdating = True
End Sub
Sub 获取文件夹(vDir As Variant, nSearchDir As Integer)
Dim sDir As String, nDir As Integer
sDir = Dir(vDir(nSearchDir) & "\*.*", vbDirectory)
Do While sDir <> ""
If Not (sDir = "." Or sDir = "..") And GetAttr(vDir(nSearchDir) & "" & sDir) = vbDirectory Then
nDir = 1 + UBound(vDir)
ReDim Preserve vDir(1 To nDir)
vDir(nDir) = vDir(nSearchDir) & "" & sDir
End If
sDir = Dir
Loop
If nSearchDir < UBound(vDir) Then
nSearchDir = nSearchDir + 1
获取文件夹 vDir, nSearchDir
End If
End Sub
Sub 获取文件名(vFile As Variant, ByVal sDir As String)
Dim sFile As String
sFile = sDir & "\*.xls*"
Do While sFile <> ""
ReDim Preserve vFile(1 To UBound(vFile) - (Trim(vFile(1)) <> ""))
vFile(UBound(vFile)) = sDir & "" & sFile
sFile = Dir
Loop
End Sub

复制代码

microyip · 发表于 2017-3-7 08:43

附上附件以供参考

chxw68 · 发表于 2017-3-7 08:44

我是小黑屋发表于 2017-3-7 00:13
老师您好，我想将您代码中第14行这一句 With .Worksheets("sheet1")改为指定工作表名称，例如 With .Work ...

可能是有的工作簿中不存在“测试"工作表引起的错误。

我是小黑屋 · 发表于 2017-3-7 08:49

chxw68 发表于 2017-3-7 08:44
可能是有的工作簿中不存在“测试"工作表引起的错误。

那有什么办法解决吗，因为有会出现工作簿中没有"测试"工作表的存在

我是小黑屋 · 发表于 2017-3-7 08:52

chxw68 发表于 2017-3-7 08:44
可能是有的工作簿中不存在“测试"工作表引起的错误。

如其中一个文件夹中有2个工作簿，只有其中一个工作簿有"测试"这个工作表,而没有“测试”工作表这个工作簿就可以忽略了

microyip · 发表于 2017-3-7 08:56

On Error Resume Next
Set wSH=Sheets("测试")
If Not wSH is Nothing Then'说明表是存在的
Endif

chxw68 · 发表于 2017-3-7 08:57

修改好了。

kzg2013 · 发表于 2017-3-7 16:28

是，可以自定义一个遍历过程，循环调用

河阳小子 · 发表于 2017-3-8 13:54

kzg2013 发表于 2017-3-6 21:15
解压后，有一个"宏表格",点击，即可

要是汇总B店的话，以下宏代码是怎么修改？修改哪里？求指教

Sub findfile()
ActiveSheet.Cells.ClearContents
Application.ScreenUpdating = False
Dim fso, fd, fd1, fl, WB As Object
Dim ar As Variant
Dim r, R1 As Long
Dim s As String
s = ActiveWorkbook.Path

Set fso = CreateObject("scripting.filesystemobject")

Set fd = fso.getfolder(s) 'first grade

For Each fl In fd.Files

   If UCase(fso.getextensionname(fl)) = "XLS" Or UCase(fso.getextensionname(fl)) = "XLSX" Then

      Set WB = GetObject(fl)
      r = ActiveSheet.Range("a1048576").End(xlUp).Row
      R1 = WB.Sheets(1).UsedRange.Rows.Count
      ar = WB.Sheets(1).Range("A2:C" & R1)
            For m = 1 To UBound(ar)
            If UCase(ar(m, 3)) Like "A*" Then
            WB.Sheets(1).Range("a" & m + 1 & ":" & "c" & m + 1).Copy ActiveSheet.Range("A" & r)
            r = r + 1
               End If
            Next m
   WB.Close

   End If
   Set fl = Nothing
   Next fl

      For Each fd1 In fd.subfolders 'second grade

            For Each fl In fd1.Files
               If UCase(fso.getextensionname(fl)) = "XLS" Or UCase(fso.getextensionname(fl)) = "XLSX" Then
               Set WB = GetObject(fl)
               R1 = WB.Sheets(1).Range("a1048576").End(xlUp).Row
               ar = WB.Sheets(1).Range("A2:C" & R1)
               For m = 1 To UBound(ar)
               If UCase(ar(m, 3)) Like "A*" Then
               WB.Sheets(1).Range("a" & m + 1 & ":" & "c" & m + 1).Copy ActiveSheet.Range("A" & ActiveSheet.Range("a1048576").End(xlUp).Row + 1)

               End If
               Next m
               WB.Close
               End If
               Set fl = Nothing
               Next fl

                     For Each fd2 In fd1.subfolders ' third grade

                        For Each fl In fd2.Files
                        If UCase(fso.getextensionname(fl)) = "XLS" Or UCase(fso.getextensionname(fl)) = "XLSX" Then
                        Set WB = GetObject(fl)
                     r = ActiveSheet.Range("a1048576").End(xlUp).Row
                        R1 = WB.Sheets(1).Range("a1048576").End(xlUp).Row
                        ar = WB.Sheets(1).Range("A2:C" & R1)
                        For m = 1 To UBound(ar)
                        If UCase(ar(m, 3)) Like "A*" Then
                     WB.Sheets(1).Range("a" & m + 1 & ":" & "c" & m + 1).Copy ActiveSheet.Range("A" & ActiveSheet.Range("a1048576").End(xlUp).Row + 1)

                        End If
                        Next m
                     WB.Close

                        End If
                     Set fl = Nothing
                     Next fl
                     Next fd2

   Next fd1
Application.ScreenUpdating = True
Set fso = Nothing
Set fd1 = Nothing
Set fd2 = Nothing
Set WB = Nothing
End Sub

lsc900707 · 发表于 2017-3-8 15:41

河阳小子发表于 2017-3-8 13:54
要是汇总B店的话，以下宏代码是怎么修改？修改哪里？求指教

Sub findfile()

把代码中的 If UCase(ar(m, 3)) Like "A*" Then改成
If UCase(ar(m, 3)) Like "B*" Then

		自动登录	找回密码
密码			免费注册

[求助] 多工作簿数据汇总指定条件的数据

评分

评分