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

lsc900707

河阳小子 发表于 2017-3-16 10:20
老师，我用之前那个案例修改了下，当然实际应用中不止这些簿和表，量很大。所以我把它们修改成实际应用中 ...

好，只能晚上弄好给你。

lsc900707

河阳小子 发表于 2017-3-16 10:20
老师，我用之前那个案例修改了下，当然实际应用中不止这些簿和表，量很大。所以我把它们修改成实际应用中 ...

你这个比较复杂，要用递归的方法合并数据。

河阳小子

lsc900707 发表于 2017-3-18 17:54
你这个比较复杂，要用递归的方法合并数据。

谢谢老师，你编写的这个宏太强大了，比之前的宏模版强大了很多很多，跪拜呀！！！只是再麻烦一下，这个宏代码能不能灵活修改成想汇总的列（实际工作中可能会汇总其他列），比如修改成汇总E列的高中文化程度或汇总H列的农民工。我试着修改了下代码，但是总调试不正确，求大神再赐教一下，万万分的感谢！！！！！！你原先编写的统计性别的宏代码如下：
Dim sh
Sub 按钮2_Click()
    Application.ScreenUpdating = False
    Set fso = CreateObject("scripting.filesystemobject")
    ActiveSheet.UsedRange.Offset(2).ClearContents
    Set sh = ActiveSheet
    For Each fd In fso.getfolder(ThisWorkbook.Path).subfolders
        Getfd (fd)
    Next fd
    For i = ActiveSheet.Cells(Rows.Count, 1).End(3).Row To 3 Step -1
        If Cells(i, 3) = "女" Then Rows(i).Delete
    Next
    Application.ScreenUpdating = True
End Sub
Sub Getfd(ByVal pth)
    Set fso = CreateObject("scripting.filesystemobject")
    Set ff = fso.getfolder(pth)
    For Each f In ff.Files
        With Workbooks.Open(f)
            For Each sht In .Sheets
                sht.UsedRange.Offset(2).Copy sh.Cells(sh.Rows.Count, 1).End(3).Offset(1)
               
            Next sht
            .Close False
        End With
    Next f
    For Each fd In ff.subfolders
        Getfd (fd)
    Next fd
End Sub

lsc900707

河阳小子 发表于 2017-3-20 11:44
谢谢老师，你编写的这个宏太强大了，比之前的宏模版强大了很多很多，跪拜呀！！！只是再麻烦一下，这个宏 ...

汇总是全部汇总过来的，只是把不符合条件的删除了，你要更换条件汇总时，修改下面的语句即可：
For i = ActiveSheet.Cells(Rows.Count, 1).End(3).Row To 3 Step -1
        If Cells(i, 3) = "女" Then Rows(i).Delete
Next

河阳小子

lsc900707 发表于 2017-3-20 19:20
汇总是全部汇总过来的，只是把不符合条件的删除了，你要更换条件汇总时，修改下面的语句即可：
For i = ...

谢谢老师，原来是这么个原理，与之前那个是反向的呀，但各有各的用途，我再好好消化下，真心谢谢老师。麻烦了这么久，学到了很多东西，真有点不好意思。最后的最后，烦请老师再帮忙修改下之前那个汇总农民工的宏，要求是汇总整行，因为实际应用中行内容长短不一，有的很长，有的很短，现在的只能汇总1－9列的内容，如果增加过列内容就不会汇总后面部分的了，我自己是宏小白，麻烦老师再帮忙修改一下。附件如下：

lsc900707

河阳小子 发表于 2017-3-21 10:37
谢谢老师，原来是这么个原理，与之前那个是反向的呀，但各有各的用途，我再好好消化下，真心谢谢老师。麻 ...

哦，这个超简单，晚上回复你。

wang-way

lsc900707 发表于 2017-3-21 10:51
哦，这个超简单，晚上回复你。

谢谢大师耐心指点

lsc900707

河阳小子 发表于 2017-3-21 10:37
谢谢老师，原来是这么个原理，与之前那个是反向的呀，但各有各的用途，我再好好消化下，真心谢谢老师。麻 ...

Option Explicit
Sub test()
Dim myPath$, MyName$, sh As Worksheet, t#
Dim Arr, brr, i&, j&, m&, n&
t = Timer
myPath = ThisWorkbook.Path & "\"
MyName = Dir(myPath & "*.xls")
Application.ScreenUpdating = False
ReDim brr(1 To 100000, 1 To 50)
Do While MyName <> ""
    If MyName <> ThisWorkbook.Name Then
        n = n + 1
        Set sh = GetObject(myPath & MyName).Sheets("Sheet1")
            Arr = sh.[A1].CurrentRegion
            Workbooks(MyName).Close False
            For i = 3 To UBound(Arr)
                If Arr(i, 8) Like "农民工*" Then
                    m = m + 1
                    For j = 1 To  UBound(Arr,2)
                        brr(m, j) = Arr(i, j)
                    Next
                End If
            Next
      End If
      MyName = Dir
Loop
Set sh = Nothing
With Sheet1
     .Rows("1:3000").ClearContents
     .[A1].Resize(2, UBound(Arr, 2)).Value = Arr
     .[a3].Resize(m, UBound(brr, 2)).Value = brr
End With
Application.ScreenUpdating = True
MsgBox "汇总完成！汇总了：" & n & "个工作表；共有：" & m & "行数据。" & vbCr & "用时：" & Format(Timer - t, "0.00") & "秒", vbInformation
End Sub

lsc900707

lsc900707 发表于 2017-3-21 10:51
哦，这个超简单，晚上回复你。

1. <div class="blockcode"><blockquote>Option Explicit
   
2. Sub test()
   
3. Dim myPath$, MyName$, sh As Worksheet, t#
   
4. Dim Arr, brr, i&, j&, m&, n&
   
5. t = Timer
   
6. myPath = ThisWorkbook.Path & ""
   
7. MyName = Dir(myPath & "*.xls")
   
8. Application.ScreenUpdating = False
   
9. ReDim brr(1 To 100000, 1 To 50)
   
10. Do While MyName <> ""
    
11.     If MyName <> ThisWorkbook.Name Then
    
12.         n = n + 1
    
13.         Set sh = GetObject(myPath & MyName).Sheets("Sheet1")
    
14.             Arr = sh.[A1].CurrentRegion
    
15.             Workbooks(MyName).Close False
    
16.             For i = 3 To UBound(Arr)
    
17.                 If Arr(i, 8) Like "农民工*" Then
    
18.                     m = m + 1
    
19.                     For j = 1 To  UBound(Arr,2)
    
20.                         brr(m, j) = Arr(i, j)
    
21.                     Next
    
22.                 End If
    
23.             Next
    
24.       End If
    
25.       MyName = Dir
    
26. Loop
    
27. Set sh = Nothing
    
28. With Sheet1
    
29.      .Rows("1:3000").ClearContents
    
30.      .[A1].Resize(2, UBound(Arr, 2)).Value = Arr
    
31.      .[a3].Resize(m, UBound(brr, 2)).Value = brr
    
32. End With
    
33. Application.ScreenUpdating = True
    
34. MsgBox "汇总完成！汇总了：" & n & "个工作表；共有：" & m & "行数据。" & vbCr & "用时：" & Format(Timer - t, "0.00") & "秒", vbInformation
    
35. End Sub

复制代码

河阳小子

lsc900707 发表于 2017-3-21 17:00
Option Explicit
Sub test()
Dim myPath$, MyName$, sh As Worksheet, t#

谢谢老师，真是太好用了，跪谢！跪谢！跪谢！