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