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 '关键字 ...
随机推荐
- python --- 15 装饰器
装饰器 一.原则,目的 开闭原则: 对功能的扩展开放,对代码的修改是封闭的(不可修改的) 目的:在目标函数前或后插入一段新的代码,不改变源代码 二.装饰器的通用语法 三.多个装饰器修饰同一个函数 ...
- topcoder srm 455 div1
problem1 link 令$f[x1][y1][x2][y2]$表示矩形(x1,y1)(x2,y2)中能选出的最大值.dp即可. problem2 link 这个题应该有更好的递推公式. 我的做法 ...
- C# 文件与二进制之间的转换
/// <summary> /// 工具类:文件与二进制流间的转换 /// </summary> public class FileBinaryConvertHelper { ...
- CSS层叠样式表--找到标签
0 怎么学习CSS 1 CSS的四种引入方式 2 CSS的四种基本选择器 3 属性选择器 4 CSS伪类 5 CSS选择器优先级 6 CSS的继承性 怎么学习CSS 1.怎么找到标签(CSS选择器) ...
- 【拼接属性查询方式】MySql某一列属性值为拼接时的查询方式
数据库中某一列的值为 使用IN查询是无法查询到数据的,只能查询到IN(2)或者IN(2,3) 查询结果: , style_id) 正确方式:使用FIND_IN_SET函数 , style_id) , ...
- 【Dalston】【第四章】容错保护(Hystrix)
我们在实践微服务架构时,通常会将业务拆分成一个个微服务,微服务之间通过网络进行通信,进行互相调用,造成了微服务之间存在依赖关系.我们知道由于网络原因或者自身的原因,服务并不能保证服务的100%可用,如 ...
- LuoguP5221 Product
题目地址 题目链接 题解 注,下方\((i,j)\)均指\(gcd(i,j)\),以及证明过程有一定的跳步,请确保自己会莫比乌斯反演的基本套路. 介绍本题的\(O(n)\)和\(O(n\sqrt{n} ...
- JS获取节点的兄弟，父级，子级元素
https://blog.csdn.net/duanshuyong/article/details/7562423 先说一下JS的获取方法,其要比JQUERY的方法麻烦很多,后面以JQUERY的方法作 ...
- Android开发——去掉系统自带标题栏的几种方式
https://blog.csdn.net/qq_28585471/article/details/75991613 今天在练习自定义标题栏(Android初级开发(四)——补充3)的过程中遇到了隐藏 ...
- Component 初识组件
component组件是Vue学习的重点.重点.重点,重要的事情说三遍.所以你必须学好Vue component.其实组件就是制作自定义的标签,这些标签在HTML中是没有的.比如:<diy> ...