[已解决]求老师帮忙，用代码解决，急等，谢谢！！！！

过江龙 · 发表于 2012-3-30 15:56

请老师帮忙，所列问题在附件中，先谢谢大家！！

附件.rar (23.89 KB, 下载次数: 14)

xpw6061 · 发表于 2012-3-30 16:11

要是在用EXCEL时,表格设计合理的话,可以减少很多不必要的麻烦,为啥非要每个月一张工作簿?, 可以设计成一个工作簿中每个月一张工作表不就成了吗? 我以前见识过一位高人,是搞信贷的, 他以客户命名工作簿,有上千个客户,有上千个工作簿,每个工作簿只廖廖几行信息, 求一个汇总表,我看着就晕

过江龙 · 发表于 2012-3-30 16:32

工资表是每个月从总部其他软件里面导出来的，只能是每月一张，谢谢！！！！

zjdh · 发表于 2012-3-30 16:51

本帖最后由 zjdh 于 2012-3-30 16:59 编辑

Sub subM()
Application.ScreenUpdating = False
Set D = CreateObject("scripting.dictionary")
PathName = ThisWorkbook.Path & "\*.xls"
dirna = Dir(PathName)
Do While dirna <> ""
      If dirna <> ActiveWorkbook.Name Then
         Set SourceBook = Workbooks.Open(ThisWorkbook.Path & "\" & dirna, 0, True)
         With SourceBook.Worksheets("在职")
            For Each c In .Range("B2:S2")
                  If c.Value Like "*失业*" Then
                     x = c.Column
                  End If
            Next c
            arr = .Range("A5:P" & Range("A65536").End(3).Row)
         End With
         For i = 1 To UBound(arr)
            D(arr(i, 2)) = D(arr(i, 2)) + arr(i, x)
            ALL = ALL + arr(i, x)
         Next
         SourceBook.Close False
      End If
      dirna = Dir
Loop
Range("A3:B1000").ClearContents
Range("A3").Resize(D.Count, 1) = Application.Transpose(D.KEYS)
Range("B3").Resize(D.Count, 1) = Application.Transpose(D.ITEMS)
Range("B2") = ALL
Application.ScreenUpdating = True
End Sub

zjdh · 发表于 2012-3-30 16:55

本帖最后由 zjdh 于 2012-3-30 16:59 编辑

汇总.rar (26.37 KB, 下载次数: 31)

过江龙 · 发表于 2012-3-30 17:23

谢谢老师，就是这样的效果。抱歉由于我没把问题说清楚，还有一个问题，就是需要统计的工作簿中在A列的中间有有合计的行就汇总。恳请老师再帮助！！1

zjdh · 发表于 2012-3-30 18:11

Sub subM()
Application.ScreenUpdating = False
Set D = CreateObject("scripting.dictionary")
PathName = ThisWorkbook.Path & "\*.xls"
dirna = Dir(PathName)
Do While dirna <> ""
      If dirna <> ActiveWorkbook.Name Then
         Set SourceBook = Workbooks.Open(ThisWorkbook.Path & "\" & dirna, 0, True)
         With SourceBook.Worksheets("在职")
            For Each c In .Range("B2:S2")
                  If c.Value Like "*失业*" Then
                     x = c.Column
                  End If
            Next c
            arr = .Range("A4:P" & Range("A65536").End(3).Row)
         End With
         For i = 2 To UBound(arr)
            D(arr(i, 2)) = D(arr(i, 2)) + arr(i, x)
         Next
         ALL = ALL + arr(1, x)
         SourceBook.Close False
      End If
      dirna = Dir
Loop
Range("A3:B1000").ClearContents
Range("A3").Resize(D.Count, 1) = Application.Transpose(D.KEYS)
Range("B3").Resize(D.Count, 1) = Application.Transpose(D.ITEMS)
Range("B2") = ALL
Application.ScreenUpdating = True
End Sub

过江龙 · 发表于 2012-3-30 20:06

老师，谢谢你的耐心帮助。可能老师理解错了，例如工作薄2012-04中，除了第3、4行不需汇总外，还有14行也不要汇总，因为A14为“合计”。也可能A34、A190.......都为“合计”，不定。只要是A列有“合计”的行就不需合计。不知我表述明白没有，谢谢老师！麻烦了！！！！

过江龙 · 发表于 2012-3-31 10:53

要沉了，为了好让老师看见，顶一哈。

zjdh · 发表于 2012-3-31 08:10

本帖最后由 zjdh 于 2012-3-31 08:12 编辑

Sub subM()
Application.ScreenUpdating = False
Set D = CreateObject("scripting.dictionary")
PathName = ThisWorkbook.Path & "\*.xls"
dirna = Dir(PathName)
Do While dirna <> ""
      If dirna <> ActiveWorkbook.Name Then
         Set SourceBook = Workbooks.Open(ThisWorkbook.Path & "\" & dirna, 0, True)
         With SourceBook.Worksheets("在职")
            For Each c In .Range("B2:S2")
                  If c.Value Like "*失业*" Then
                     x = c.Column
                  End If
            Next c
            arr = .Range("A4:P" & Range("A65536").End(3).Row)
         End With
         For i = 2 To UBound(arr)
            If Not arr(i, 1) Like "*合计*" Then D(arr(i, 2)) = D(arr(i, 2)) + arr(i, x)
            ALL = ALL + arr(i, x)
         Next
         SourceBook.Close False
      End If
      dirna = Dir
Loop
Range("A3:B1000").ClearContents
Range("A3").Resize(D.Count, 1) = Application.Transpose(D.KEYS)
Range("B3").Resize(D.Count, 1) = Application.Transpose(D.ITEMS)
Range("B2") = ALL
Application.ScreenUpdating = True
End Sub

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