汇总文件夹下分表的数据

yrjgoodluck666

跪求代码：汇总文件夹下分表的数据，详见附件说明，谢谢！

lsc900707

各项数据都可以从“工资表”中取得呀。

iwangyi

Sub 多表汇总()
Set FSO = CreateObject("SCRIPTING.FILESYSTEMOBJECT")
Set FF = FSO.GETFOLDER(ThisWorkbook.Path)
For Each F In FF.Files
If InStr(F.Name, ThisWorkbook.Name) = 0 Then
   Set WB = Workbooks.Open(F)
   n = [B65536].End(3).Row + 1
     For Each SH In Sheets
       If SH.Name = "工资表" Then
         Cells(n, 2) = Sheets("工资表").Cells(2, 3)
          arr = Sheets("工资表").UsedRange
            Set d = CreateObject("scripting.dictionary")
            Set d1 = CreateObject("scripting.dictionary")
              For i = 2 To UBound(arr)
             d(arr(i, 13)) = d(arr(i, 13)) + arr(i, 44)
             d1(arr(i, 13)) = d1(arr(i, 13)) + arr(i, 48)
             Cells(n, 5) = d("在职"): Cells(n, 6) = d1("在职")
             Next
         End If
      If SH.Name = "汇总表" Then
      Cells(n, 3) = Sheets("汇总").Range("h18")
      Cells(n, 4) = Sheets("汇总").Range("h19")
      End If
      Next
      WB.Close False
End If
Next
End Sub

yrjgoodluck666

lsc900707 发表于 2018-8-30 20:56
各项数据都可以从“工作表”中取得呀。

可是我不会写代码

yrjgoodluck666

lsc900707 发表于 2018-8-30 20:56
各项数据都可以从“工作表”中取得呀。

可是我不会写代码

yrjgoodluck666

lsc900707 发表于 2018-8-30 20:56
各项数据都可以从“工作表”中取得呀。

可是我不会写代码

opiona

http://club.excelhome.net/thread-1409141-1-1.html

iwangyi

Sub 多表汇总()
Set FSO = CreateObject("SCRIPTING.FILESYSTEMOBJECT")
Set FF = FSO.GETFOLDER(ThisWorkbook.Path)
For Each F In FF.Files
If InStr(F.Name, ThisWorkbook.Name) = 0 Then
   Set WB = Workbooks.Open(F)
   n = [B65536].End(3).Row + 1
     For Each SH In Sheets
       If SH.Name = "工资表" Then
         Cells(n, 2) = Sheets("工资表").Cells(2, 3)
          arr = Sheets("工资表").UsedRange
            Set d = CreateObject("scripting.dictionary")
            Set d1 = CreateObject("scripting.dictionary")
              For i = 2 To UBound(arr)
             d(arr(i, 13)) = d(arr(i, 13)) + arr(i, 44)
             d1(arr(i, 13)) = d1(arr(i, 13)) + arr(i, 48)
             Cells(n, 5) = d("在职"): Cells(n, 6) = d1("在职")
             Next
         End If
      If SH.Name = "汇总表" Then
      Cells(n, 3) = Sheets("汇总").Range("h18")
      Cells(n, 4) = Sheets("汇总").Range("h19")
      End If
      Next
      WB.Close False
End If
Next
End Sub

lsc900707

yrjgoodluck666 发表于 2018-8-30 21:38
可是我不会写代码

Sub test()
    Dim arB(1 To 10000, 1 To 6)
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xlsx")
    Application.ScreenUpdating = False
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(p & f)
            With wb.Sheets("工资表")
                r = .Cells(.Rows.Count, 1).End(3).Row
                arA = .Range("a1:av" & r)
                n = n + 1
                arB(n, 1) = n
                arB(n, 2) = Replace(Split(f, ".")(0), "工资表", "")
                For i = 2 To UBound(arA)
                    arB(n, 3) = arB(n, 3) + arA(i, 44)
                    arB(n, 4) = arB(n, 4) + arA(i, 48)
                    If InStr(arA(i, 13), "自离") = 0 Then
                        arB(n, 5) = arB(n, 5) + arA(i, 44)
                        arB(n, 6) = arB(n, 6) + arA(i, 48)
                    End If
                Next
            End With
            wb.Close False
        End If
        f = Dir
    Loop
    Set wb = Nothing
    With Sheet1
        .[a1].CurrentRegion.Offset(1).ClearContents
        .[a2].Resize(n, 6) = arB
    End With
    Application.ScreenUpdating = True
    MsgBox "ok!"
End Sub

lsc900707

yrjgoodluck666 发表于 2018-8-30 21:38
可是我不会写代码

参考测试附件吧：