20170914xlVBA通讯公司分类汇总

Sub 租房()
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim OpenWb As Workbook
    Dim OpenSht As Worksheet
    Dim FolderPath As String
    Dim FileName As String
    Dim FilePath As String
    Dim Pat As String
    Dim dSum As Object
    Dim dCount As Object
    Dim Key As String
    Dim Rng As Range
    Dim Arr As Variant
    Dim mySum As Double
    Dim myCount As Double
    Set Wb = Application.ThisWorkbook
    FolderPath = Wb.Path & ""
    Set Sht = Wb.Worksheets("租房数据")
    With Sht
        .UsedRange.Offset(2, 2).ClearContents
        EndCol = .Cells(2, .Cells.Columns.Count).End(xlToLeft).Column
        
        For j = 3 To EndCol
            If .Cells(1, j).Text <> "" Then
                
                Set dSum = CreateObject("Scripting.Dictionary")
                Set dCount = CreateObject("Scripting.Dictionary")
                
                FileName = ""
                Pat = "*" & "租房台帐" & "*" & Replace(Replace(.Cells(1, j).Text, "年", "*"), "月", "*")
                Debug.Print Pat
                FileName = Dir(FolderPath & Pat)
                Debug.Print "FileName "; FileName
                If FileName <> "" Then FilePath = FolderPath & FileName
                Debug.Print FilePath
                
                Set OpenWb = Application.Workbooks.Open(FilePath)
                Set OpenSht = OpenWb.Worksheets(OpenWb.Worksheets.Count)
                With OpenSht
                    
                    endrow = .Cells(.Cells.Rows.Count, "E").End(xlUp).Row
                    Set Rng = .Range("A3:AG" & endrow)
                    Arr = Rng.Value
                    For i = LBound(Arr) To UBound(Arr)
                        Key = CStr(Arr(i, 5))
                        dSum(Key) = dSum(Key) + Arr(i, 13)
                        dCount(Key) = dCount(Key) + 1
                    Next i
                End With
                
                OpenWb.Close False
                
                
                Pat = "*" & "自签租房合同" & "*" & Replace(Replace(.Cells(1, j).Text, "年", "*"), "月", "*")
                Debug.Print Pat
                FileName = Dir(FolderPath & Pat)
                If FileName <> "" Then FilePath = FolderPath & FileName
                Debug.Print FilePath
                
                Set OpenWb = Application.Workbooks.Open(FilePath)
                Set OpenSht = OpenWb.Worksheets(OpenWb.Worksheets.Count)
                With OpenSht
                    
                    endrow = .Cells(.Cells.Rows.Count, "E").End(xlUp).Row
                    Set Rng = .Range("A3:AG" & endrow)
                    Arr = Rng.Value
                    For i = LBound(Arr) To UBound(Arr)
                        Key = CStr(Arr(i, 5))
                        dSum(Key) = dSum(Key) + Arr(i, 13)
                        dCount(Key) = dCount(Key) + 1
                    Next i
                End With
                
                OpenWb.Close False
                
                
                
                endrow = .Cells(.Cells.Rows.Count, "B").End(xlUp).Row
                mySum = 0
                myCount = 0
                For i = 3 To endrow - 1
                    Key = .Cells(i, 2).Text
                    If dSum.Exists(Key) Then
                        .Cells(i, j).Value = dSum(Key)
                        .Cells(i, j + 1).Value = dCount(Key)
                        .Cells(i, j + 2).Value = Format(dSum(Key) / dCount(Key), "0.00")
                        mySum = mySum + dSum(Key)
                        myCount = myCount + dCount(Key)
                    End If
                Next i
                
                .Cells(endrow, j).Value = mySum
                .Cells(endrow, j + 1).Value = myCount
                .Cells(endrow, j + 2).Value = mySum / myCount
            End If
        Next j
    End With
    
    Set Wb = Nothing
    Set dSum = Nothing
    Set OpenWb = Nothing
    Set OpenSht = Nothing
    Set Rng = Nothing
    
    
End Sub

　　

Sub 租车()
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim OpenWb As Workbook
    Dim OpenSht As Worksheet
    Dim FolderPath As String
    Dim FileName As String
    Dim FilePath As String
    Dim Pat As String
    Dim dSum As Object
    Dim dCount As Object
    Dim Key As String
    Dim Rng As Range
    Dim Arr As Variant
    Dim mySum As Double
    Dim myCount As Double
    Set Wb = Application.ThisWorkbook
    FolderPath = Wb.Path & ""
    Set Sht = Wb.Worksheets("租车数据")
    With Sht
        .UsedRange.Offset(2, 2).ClearContents
        EndCol = .Cells(2, .Cells.Columns.Count).End(xlToLeft).Column

        For j = 3 To EndCol
            If .Cells(1, j).Text <> "" Then
                Pat = "*" & "租车合同" & "*" & Replace(Replace(.Cells(1, j).Text, "年", "*"), "月", "*")
                Debug.Print Pat
                FileName = Dir(FolderPath & Pat)
                If FileName <> "" Then FilePath = FolderPath & FileName
                Debug.Print FilePath
                Set dSum = CreateObject("Scripting.Dictionary")
                Set dCount = CreateObject("Scripting.Dictionary")
                Set OpenWb = Application.Workbooks.Open(FilePath)
                Set OpenSht = OpenWb.Worksheets(OpenWb.Worksheets.Count)
                With OpenSht

                    endrow = .Cells(.Cells.Rows.Count, "E").End(xlUp).Row
                    Set Rng = .Range("A4:AG" & endrow)
                    Arr = Rng.Value
                    For i = LBound(Arr) To UBound(Arr)
                        Key = CStr(Arr(i, 5))
                        dSum(Key) = dSum(Key) + Arr(i, 13)
                        dCount(Key) = dCount(Key) + 1
                    Next i
                End With

                OpenWb.Close False

                endrow = .Cells(.Cells.Rows.Count, "B").End(xlUp).Row
                mySum = 0
                myCount = 0
                For i = 3 To endrow - 1
                    Key = .Cells(i, 2).Text
                    If dSum.Exists(Key) Then
                        .Cells(i, j).Value = dSum(Key)
                        .Cells(i, j + 1).Value = dCount(Key)
                        .Cells(i, j + 2).Value = Format(dSum(Key) / dCount(Key), "0.00")
                        mySum = mySum + dSum(Key)
                        myCount = myCount + dCount(Key)
                    End If
                Next i

                .Cells(endrow, j).Value = mySum
                .Cells(endrow, j + 1).Value = myCount
                .Cells(endrow, j + 2).Value = mySum / myCount
            End If
        Next j
    End With

    Set Wb = Nothing
    Set dSum = Nothing
    Set OpenWb = Nothing
    Set OpenSht = Nothing
    Set Rng = Nothing


End Sub

　　

Sub 折旧()
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim OpenWb As Workbook
    Dim OpenSht As Worksheet
    Dim FolderPath As String
    Dim FileName As String
    Dim FilePath As String
    Dim Pat As String
    Dim dSum As Object
    Dim Key As String
    Dim Rng As Range
    Dim Arr As Variant
    Dim mySum As Double
    
    Set Wb = Application.ThisWorkbook
    FolderPath = Wb.Path & ""
    Set Sht = Wb.Worksheets("固定资产数据")
    With Sht
        .UsedRange.Offset(1, 2).ClearContents
        EndCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
        For j = 3 To EndCol
            Pat = "*" & Replace(Replace(.Cells(1, j).Text, "年", "*"), "月", "*") & "折旧表" & "*"
            Debug.Print Pat
            FileName = Dir(FolderPath & Pat)
            If FileName <> "" Then FilePath = FolderPath & FileName
            Debug.Print FilePath
            Set dSum = CreateObject("Scripting.Dictionary")
            Set OpenWb = Application.Workbooks.Open(FilePath)
            Set OpenSht = OpenWb.Worksheets(1)
            With OpenSht
                endrow = .Cells(.Cells.Rows.Count, "T").End(xlUp).Row
                Set Rng = .Range("T2:V" & endrow)
                Arr = Rng.Value
                For i = LBound(Arr) To UBound(Arr)
                    Key = CStr(Arr(i, 3))
                    dSum(Key) = dSum(Key) + Arr(i, 1)
                Next i
                
            End With
            OpenWb.Close False
            
            endrow = .Cells(.Cells.Rows.Count, "B").End(xlUp).Row
            mySum = 0
            For i = 2 To endrow - 1
                Key = .Cells(i, 2).Text
                If dSum.Exists(Key) Then
                    .Cells(i, j).Value = dSum(Key)
                    mySum = mySum + dSum(Key)
                End If
            Next i
            .Cells(endrow, j).Value = mySum
        Next j
    End With
    
    Set Wb = Nothing
    Set dSum = Nothing
    Set OpenWb = Nothing
    Set OpenSht = Nothing
    Set Rng = Nothing
    
    
End Sub

　　

Sub 五险一金()
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim OpenWb As Workbook
    Dim OpenSht As Worksheet
    Dim FolderPath As String
    Dim FileName As String
    Dim FilePath As String
    Dim Pat As String
    Dim dSum As Object
    Dim dSumB As Object
    Dim dCount As Object
    Dim Key As String
    Dim Rng As Range
    Dim Arr As Variant
    Dim mySum As Double
    Dim mySumB As Double
    Dim myCount As Double
    Set Wb = Application.ThisWorkbook
    FolderPath = Wb.Path & ""
    Set Sht = Wb.Worksheets("五险一金数据")
    With Sht
        .UsedRange.Offset(2, 1).ClearContents
        EndCol = .Cells(2, .Cells.Columns.Count).End(xlToLeft).Column
        
        For j = 2 To EndCol
            If .Cells(1, j).Text <> "" Then
                
                Set dSum = CreateObject("Scripting.Dictionary")
                Set dSumB = CreateObject("Scripting.Dictionary")
                Set dCount = CreateObject("Scripting.Dictionary")
                
                FileName = ""
                Pat = "*" & Replace(Replace(.Cells(1, j).Text, "年", "*"), "月", "*") & "社保" & "*"
                Debug.Print Pat
                
                FileName = Dir(FolderPath & Pat)
                
                Debug.Print "FileName "; FileName
                If FileName <> "" Then FilePath = FolderPath & FileName
                Debug.Print FilePath
                
                Set OpenWb = Application.Workbooks.Open(FilePath)
                Set OpenSht = OpenWb.Worksheets("社保")
                With OpenSht
                    endrow = .Cells(.Cells.Rows.Count, "B").End(xlUp).Row
                    Set Rng = .Range("A3:D" & endrow)
                    Arr = Rng.Value
                    For i = LBound(Arr) To UBound(Arr)
                        Key = CStr(Arr(i, 2)) ' Replace(CStr(Arr(i, 2)), "（网络维护）", "")
                        dSum(Key) = dSum(Key) + Arr(i, 4)
                        dCount(Key) = dCount(Key) + 1
                    Next i
                End With
                
                Set OpenSht = OpenWb.Worksheets("公积金")
                With OpenSht
                    endrow = .Cells(.Cells.Rows.Count, "B").End(xlUp).Row
                    Set Rng = .Range("A3:D" & endrow)
                    Arr = Rng.Value
                    For i = LBound(Arr) To UBound(Arr)
                        Key = CStr(Arr(i, 2))
                        dSumB(Key) = dSumB(Key) + Arr(i, 4)
                        'dCount(Key) = dCount(Key) + 1
                    Next i
                End With
                
                OpenWb.Close False
                
                endrow = .Cells(.Cells.Rows.Count, "A").End(xlUp).Row
                mySum = 0
                mySumB = 0
                myCount = 0
                For i = 3 To endrow - 1
                    Key = .Cells(i, 1).Text
                    If dSum.Exists(Key) Then
                        .Cells(i, j).Value = dSum(Key)
                        .Cells(i, j + 1).Value = dSumB(Key)
                        .Cells(i, j + 2).Value = dSum(Key) + dSumB(Key)
                        .Cells(i, j + 3).Value = dCount(Key)
                        .Cells(i, j + 4).Value = Format((dSum(Key) + dSumB(Key)) / dCount(Key), "0.00")
                        mySum = mySum + dSum(Key)
                        mySumB = mySumB + dSumB(Key)
                        myCount = myCount + dCount(Key)
                    End If
                Next i
                If myCount > 0 Then
                .Cells(endrow, j).Value = mySum
                .Cells(endrow, j + 1).Value = mySumB
                .Cells(endrow, j + 2).Value = mySum + mySumB
                .Cells(endrow, j + 3).Value = myCount
                .Cells(endrow, j + 4).Value = (mySum + mySumB) / myCount
                End If
            End If
        Next j
    End With
    
    Set Wb = Nothing
    Set dSum = Nothing
    Set OpenWb = Nothing
    Set OpenSht = Nothing
    Set Rng = Nothing
    
    
End Sub

　　

Sub 薪酬()
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim OpenWb As Workbook
    Dim OpenSht As Worksheet
    Dim FolderPath As String
    Dim FileName As String
    Dim FilePath As String
    Dim Pat As String
    Dim dSum As Object
    Dim dSumB As Object
    Dim dCount As Object
    Dim Key As String
    Dim Rng As Range
    Dim Arr As Variant
    Dim mySum As Double
    Dim mySumB As Double
    Dim myCount As Double
    Set Wb = Application.ThisWorkbook
    FolderPath = Wb.Path & ""
    Set Sht = Wb.Worksheets("薪酬")
    With Sht
        .UsedRange.Offset(2, 2).ClearContents
        EndCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
        
        For j = 2 To EndCol
            If .Cells(1, j).Text <> "" Then
                
                Set dSum = CreateObject("Scripting.Dictionary")
                Set dSumB = CreateObject("Scripting.Dictionary")
                Set dCount = CreateObject("Scripting.Dictionary")
                
                FileName = ""
                
                Pat = "*" & Replace(Replace(.Cells(1, j).Text, "年", "*"), "月", "*") & "工资" & "*"
                Debug.Print Pat
                FileName = Dir(FolderPath & Pat)
                'Debug.Print "FileName "; FileName
                If FileName <> "" Then FilePath = FolderPath & FileName
                Debug.Print FilePath
                
                Set OpenWb = Application.Workbooks.Open(FilePath)
                Set OpenSht = OpenWb.Worksheets(OpenWb.Worksheets.Count)
                With OpenSht
                    
                    endrow = .Cells(.Cells.Rows.Count, "B").End(xlUp).Row
                    Set Rng = .Range("A3:E" & endrow)
                    Arr = Rng.Value
                    For i = LBound(Arr) To UBound(Arr)
                        Key = CStr(Arr(i, 2)) ' Replace(CStr(Arr(i, 2)), "（网络维护）", "")
                        'Debug.Print Key
                        dSum(Key) = dSum(Key) + Arr(i, 5)
                        dCount(Key) = dCount(Key) + 1
                    Next i
                End With
                OpenWb.Close False
                
                '********************
                Pat = "*" & Replace(Replace(.Cells(1, j).Text, "年", "*"), "月", "*") & "外协" & "*"
                Debug.Print Pat
                FileName = Dir(FolderPath & Pat)
                If FileName <> "" Then FilePath = FolderPath & FileName
                
                'Debug.Print "FileName "; FileName
                Debug.Print FilePath
                
                Set OpenWb = Application.Workbooks.Open(FilePath)
                Set OpenSht = OpenWb.Worksheets(OpenWb.Worksheets.Count)
                With OpenSht
                    endrow = .Cells(.Cells.Rows.Count, "B").End(xlUp).Row
                    Set Rng = .Range("A3:AG" & endrow)
                    Arr = Rng.Value
                    For i = LBound(Arr) To UBound(Arr)
                        Key = CStr(Arr(i, 2))  ' Replace(CStr(Arr(i, 2)), "（网络维护）", "")
                        dSumB(Key) = dSumB(Key) + Arr(i, 5)
                        dCount(Key) = dCount(Key) + 1
                    Next i
                End With
                OpenWb.Close False
                
                '********************
                Pat = "*" & "骏捷" & "*" & Replace(Replace(.Cells(1, j).Text, "年", "*"), "月", "*")
                Debug.Print Pat
                FileName = Dir(FolderPath & Pat)
                If FileName <> "" Then FilePath = FolderPath & FileName
                
                'Debug.Print "FileName "; FileName
                Debug.Print FilePath
                
                Set OpenWb = Application.Workbooks.Open(FilePath)
                Set OpenSht = OpenWb.Worksheets(OpenWb.Worksheets.Count)
                With OpenSht
                    endrow = .Cells(.Cells.Rows.Count, "B").End(xlUp).Row
                    Set Rng = .Range("A3:C" & endrow)
                    Arr = Rng.Value
                    For i = LBound(Arr) To UBound(Arr)
                        If Len(Arr(i, 3)) > 0 Then
                            Key = CStr(Arr(i, 1))  ' Replace(CStr(Arr(i, 1)), "（网络维护）", "")
                            dSumB(Key) = dSumB(Key) + Arr(i, 2)
                            dCount(Key) = dCount(Key) + Arr(i, 3)
                        End If
                    Next i
                End With
                OpenWb.Close False
                
                endrow = .Cells(.Cells.Rows.Count, "a").End(xlUp).Row
                mySum = 0
                mySumB = 0
                myCount = 0
                
                For i = 3 To endrow - 1
                    Key = .Cells(i, 1).Text
                    'Debug.Print Key
                    If dSum.Exists(Key) Then
                        .Cells(i, j).Value = dSum(Key)
                        .Cells(i, j + 1).Value = dSumB(Key)
                        .Cells(i, j + 2).Value = dSum(Key) + dSumB(Key)
                        .Cells(i, j + 3).Value = dCount(Key)
                        .Cells(i, j + 4).Value = Format((dSum(Key) + dSumB(Key)) / dCount(Key), "0.00")
                        mySum = mySum + dSum(Key)
                        mySumB = mySumB + dSumB(Key)
                        myCount = myCount + dCount(Key)
                    End If
                Next i
                
                If myCount > 0 Then
                    .Cells(endrow, j).Value = mySum
                    .Cells(endrow, j + 1).Value = mySumB
                    .Cells(endrow, j + 2).Value = mySum + mySumB
                    .Cells(endrow, j + 3).Value = myCount
                    .Cells(endrow, j + 4).Value = (mySum + mySumB) / myCount
                End If
                
            End If
        Next j
    End With
    
    Set Wb = Nothing
    Set dSum = Nothing
    Set OpenWb = Nothing
    Set OpenSht = Nothing
    Set Rng = Nothing
    
    
End Sub