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 '关键字 ...
随机推荐
- topcoder srm 663 div1
problem1 link 每次枚举$S$的两种变化,并判断新的串是否是$T$的子串.不是的话停止搜索. problem2 link 首先考慮增加1个面值为1的硬币后,$ways$数组有什么变化.设原 ...
- topcoder srm 714 div1
problem1 link 倒着想.每次添加一个右括号再添加一个左括号,直到还原.那么每次的右括号的选择范围为当前左括号后面的右括号减去后面已经使用的右括号. problem2 link 令$h(x) ...
- [POI2011]Garbage 欧拉回路
[POI2011]Garbage 链接 https://www.lydsy.com/JudgeOnline/problem.php?id=2278 https://loj.ac/problem/216 ...
- Why there is two completely different version of Reverse for List and IEnumerable?
https://stackoverflow.com/questions/12390971/why-there-is-two-completely-different-version-of-revers ...
- 搭建git 服务器
Gogs 什么是 Gogs? Gogs 是一款极易搭建的自助 Git 服务. https://gogs.io/docs
- (转) K-Means聚类的Python实践
本文转自: http://python.jobbole.com/87343/ K-Means聚类的Python实践 2017/02/11 · 实践项目 · K-means, 机器学习 分享到:1 原文 ...
- java.lang.NoClassDefFoundError: com/gexin/rp/sdk/exceptions/RequestException解决方法
本文为博主原创,未经允许不得转载: 最近在开发个推的时候遇到的问题,当我在maven仓库中下载个推的jar包时,下载不下来,索性在项目中Configue build Path,将jar下载到本地 手动 ...
- Latex: 添加IEEE论文keywords
参考: How to use \IEEEkeywords Latex: 添加IEEE论文keywords 方法: \begin{IEEEkeywords} keyword1, keyword2. \e ...
- Git回顾
抄自廖雪峰的官方网站 完整图文请访问https://github.com/Mrlution/study/tree/master/git 关于repository 我认为repository是一个存放代 ...
- 异步加载script,提高前端性能(defer和async属性的区别)
一.异步加载script的好处 为了加快首屏响应速度,前端会采用代码切割.按需加载等方式优化性能.异步加载script也是一种前端优化的手段. 就好比如果我的页面其中一个功能需要打开地图,但是地图的j ...