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 '关键字 ...
随机推荐
- Mac安装HomeBridge适配小米Homekit报错：module未找到解决
Mac安装HomeBridge适配小米Homekit报错:module未找到 具体错误是: module.js:471 throw err; balabalal...... 问了一圈,终于解决,但是又 ...
- topcoder srm 400 div1
problem1 link 枚举指数,然后判断是不是素数即可. problem2 link 令$f[len][a][b][r]$(r=0或者1)表示子串$init[a,a+len-1]$匹配$goal ...
- ODAC（V9.5.15) 学习笔记（五）TSmartQuery
TSmartQuery是相对于TOraQuery更简洁的数据集,其成员如下 名称 类型 说明 Expand Boolean 缺省为False,如果为True,则表示无论SQL中罗列的字段是哪些,数据集 ...
- selinux权限问题【转】
本文转载自:https://blog.csdn.net/u011386173/article/details/83339770 版权声明:本文为博主原创文章,未经博主允许不得转载. https://b ...
- Linux 使用statvfs读取文件系统信息
本文转载自:https://blog.csdn.net/papiping/article/details/6980573 在测试过程中,f_bfree的值比f_frsize的值大于10%的尺寸大小,意 ...
- noip模拟【tea】
tea [题目描述]有n个容量为V的瓶子,第i个瓶子中装着a[i]个单位的tea,使所有瓶子内的tea在不 超过其容量的前提下,非空的瓶子最少.在一个单位时间内,可以同时将多个瓶子中的tea倒入另外多 ...
- P4720 【模板】扩展卢卡斯
思路 扩展Lucas和Lucas定理其实没什么关系 我们要求的是这样的一个问题 \[ \left(\begin{matrix}n\\m\end{matrix}\right) mod\ P \] p不一 ...
- 洛谷P1164 小A点菜 DP入门
原题传输门>>https://www.luogu.org/problem/show?pid=1164<< 前几天开始联系DP的,一路水题做到这,发现这题套不了模板了QAQ 在大 ...
- angular-cli 正确安装步骤
npm install -g node-gyp npm install --global windows-build-tools npm install -g angular-cli
- Gym 100247B Similar Strings（哈希+思维）
https://vjudge.net/problem/Gym-100247B 题意: 如果两个字符串通过映射后是一样的,则说明这两个字符串是相似的,现在给出n个字符串,计算出有多少组字符串是相似的. ...