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
20170914xlVBA通讯公司分类汇总的更多相关文章
- SQL之按两个字段分类汇总
目的: 同时按"游戏代号"和"礼包名"分类汇总,然后获取下拉框的数据. 如下图所示: SQL查询 select game,giftname from qyg_ ...
- GitHub上史上最全的Android开源项目分类汇总 (转)
GitHub上史上最全的Android开源项目分类汇总 标签: github android 开源 | 发表时间:2014-11-23 23:00 | 作者:u013149325 分享到: 出处:ht ...
- Studio for Winforms FlexGrid: 创建分类汇总
C1FlexGrid.Subtotal方法可以增加包含普通(非小计)行的汇总数据的分类汇总行. 分类汇总支持分层聚合.例如,如果你的表格包含销售数据,你可能会通过产品.地区和推销员来小计一下以得出总的 ...
- GitHub上史上最全的Android开源项目分类汇总
今天在看博客的时候,无意中发现了 @Trinea 在GitHub上的一个项目 Android开源项目分类汇总 ,由于类容太多了,我没有一个个完整地看完,但是里面介绍的开源项目都非常有参考价值,包括很炫 ...
- Android 开源项目分类汇总(转)
Android 开源项目分类汇总(转) ## 第一部分 个性化控件(View)主要介绍那些不错个性化的 View,包括 ListView.ActionBar.Menu.ViewPager.Galler ...
- Android 开源项目分类汇总
Android 开源项目分类汇总 Android 开源项目第一篇——个性化控件(View)篇 包括ListView.ActionBar.Menu.ViewPager.Gallery.GridView ...
- Android开源项目分类汇总【畜生级别】[转]
Android开源项目分类汇总 欢迎大家推荐好的Android开源项目,可直接Commit或在 收集&提交页 中告诉我,欢迎Star.Fork :) 微博:Trinea 主页:www.t ...
- Android开源项目分类汇总[转]
Android开源项目分类汇总 如果你也对开源实现库的实现原理感兴趣,欢迎 Star 和 Fork Android优秀开源项目实现原理解析欢迎加入 QQ 交流群:383537512(入群理由需要填写群 ...
- 20170624xlVBA正则分割分类汇总
Sub RegExpSubtotal() '声明变量 Dim Regex As Object '正则对象 Dim Dic As Object '字典对象 Dim Key As String '关键字 ...
随机推荐
- Oracle错误——SP2-0734: 未知的命令开头 "imp C##sin..." - 忽略了剩余的行。
错误 在windows的DOS窗口下使用命令导入Oracle数据. 原因 进入sqlplus里是不能执行imp的(sqlplus不认识imp),imp 是个工具,应该在cmd的dos命令提示符下执行.
- 在cygwin下创建的文件位于windows的哪个目录下?
答: 1. C盘的SPB_Data目录下 2. 在cygwin下通过pwd命令可以查看,例如: jello@jello ~ $ pwd /cygdrive/c/SPB_Data (/cygdrive/ ...
- ZOJ 1602 Multiplication Puzzle（区间DP）题解
题意:n个数字的串,每取出一个数字的代价为该数字和左右的乘积(1.n不能取),问最小代价 思路:dp[i][j]表示把i~j取到只剩 i.j 的最小代价. 代码: #include<set> ...
- pgAdmin的数据导入之CSV
在向数据库批量导入数据时,可以参考此过程 1.对于现有的Excel文件,首先应另存为 .csv文件,记住分割符(逗号分割),在后边导入用到. 2.用记事本打开保存后的csv文件,以utf-8格式另存为 ...
- --HTML标签2
表单元素: <input>标签 搜集用户信息 属性:type=" " text 默认值 size 长度 value 规定值 readonly 规定值 placehold ...
- HDU 5723 Abandoned country（最小生成树+边两边点数）
http://acm.split.hdu.edu.cn/showproblem.php?pid=5723 题意:给出一个无向图,每条路都有一个代价,求出把所有城市连通的最小代价.在此基础上,国王会从这 ...
- Http_code码
_codes = { : (: (: (: (: (: (: (: (: (: (: (: (: (: (: (: (: (: (: (: (: (: (: (: (: (: (: (: (: (: ...
- vscode已有64位版本。
我的操作系统是win10 Family版本. vscode不知道什么鬼,只要开启没动任何操作,cpu就占到30%. 于是我打开任务管理器,选中vscode进程->转到详细信息->结束cpu ...
- _itemmod_gem_remove
该表可配置以一定代价移除宝石,移除后获得该宝石 `entry`宝石ID `reqId` 需求ID `chance`几率 `comond` 备注
- Trailing Zeroes (I) LightOJ - 1028
题意就是给你一个数让你找它的正因子个数(包括自身,不包括1),这个地方用到一个公式,如果不用的话按正常思路来写会TL什么的反正就是不容易写对. 求任意一个大于1的整数的正因子个数 首先任意一个数n,n ...