|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 kuaile5935 于 2015-8-5 10:46 编辑
Sub cnn_db()
Dim arr, brr, crr, drr, err, frr, MyPath$, MyName1$, MyName2$, Sql$, m%, n%, p%, i%, k%, r%, r2%, min1%, min2%, min3%, max1%, max2%, max3%, Time%
Dim cnn, d As Object
On Error Resume Next '可能有空数据或除数为0，会到时错误，所以添加词句
Application.ScreenUpdating = False
Application.DisplayAlerts = False
MyPath = ActiveWorkbook.Path & "\" '定义处理的文件的路径
MyName1 = "TxSEIK.CSV" '定义需要处理的文件名字
'MyName2 = "TxSEIK(" & Month(DateAdd("m", -1, Date)) & "月份月度内示比较).XLS" '变量打开比较的文件，默认打开上个月，需要使用时可以注释掉下面的那句话
MyName2 = "TxSEIK(比较).XLS" '定义比较的文件名字
'------------------------------------准备过程------------------------------------------
Workbooks.Open Filename:=MyPath & MyName2 '打开比较的文件，TxSEIK(比较).XLS
r2 = Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row '最后一行
drr = Range("B2:B" & r2) '把需要比较的编号写入数组
err = Range("H2:K" & r2) '把编号对应的内容写入数组
Set d = CreateObject("scripting.dictionary") '创建字典
For j = 1 To r2 - 1
d.Item(drr(j, 1)) = err(j, 1) & "_" & err(j, 3) & "_" & err(j, 4) '修改关键字所对应的条目，循环把编号、对应的内容写入字典
Next
ActiveWindow.Close True '关闭需要比较的文件
Workbooks.Open Filename:=MyPath & MyName1 '打开需要处理的文件 TxSEIK.CSV
'------------第一步的处理过程----------------此时处理的是”TxSEIK.csv“这个文件-------
Set cnn = CreateObject("ADODB.Connection") '创建数据库
cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & ActiveWorkbook.FullName '打开数据库
'下面是SQL语句，筛选[区分]=""生计"，[制造担当] 以S开头 ，[制造担当] <>""S125"、"S160"、"S172"的数据，order排序。
Sql = " select * from [TxSEIK$] where [区分]=""生计"" and [制造担当] like 'S%' and [制造担当] <>""S125"" and [制造担当] <>""S160"" and [制造担当] <>""S172"" order by [制造担当]"
Workbooks.Add '新建一个excel文件
Workbooks(MyName1).Worksheets(1).[a1:fi1].Copy ActiveWorkbook.Worksheets(1).[a1] '把TxSEIK.CSV标题写入新文件中
ActiveWorkbook.Worksheets(1).[a2].CopyFromRecordset cnn.Execute(Sql) '把数据库筛选的内容写入新文件中
ActiveWorkbook.SaveAs Filename:=MyPath & Split(MyName1, ".")(0) & "调整.csv", FileFormat:=xlCSV '保存为 调整.csv
cnn.Close '断开数据库连接
Set cnn = Nothing
Workbooks(MyName1).Close True '关闭TxSEIK.CSV，自动保存
'------------第二步的处理过程----------------此时处理的是”TxSEIK调整.csv“这个文件----
Columns("H:Q").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 'H-Q插入10列
Columns("N:O").NumberFormatLocal = "0.00%" 'N-O两列的格式设定为百分数
Columns("P:Q").NumberFormatLocal = "0.0_ " 'P-Q两列的格式设定为一位小数
'定义一个数组，用来存新插入10列的名字
arr = Array("收容数", Month(DateAdd("m", 1, Date)) & "月", Month(DateAdd("m", 2, Date)) & "月", Month(DateAdd("m", 3, Date)) & "月", _
"（" & Month(DateAdd("m", -1, Date)) & "月发行）" & Month(DateAdd("m", 1, Date)) & "月", _
"（" & Month(DateAdd("m", -1, Date)) & "月发行）" & Month(DateAdd("m", 2, Date)) & "月", _
Month(DateAdd("m", 1, Date)) & "月差异率", Month(DateAdd("m", 2, Date)) & "月差异率", _
Month(DateAdd("m", 1, Date)) & "月差异箱数", Month(DateAdd("m", 2, Date)) & "月差异箱数")
Range("H1:Q1") = arr '把数组中的名字写入到H-Q的第一行
r = Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row '获取最后一行
brr = Range("R1:FF" & r) '把日期下的数据写入数组等待处理
frr = Range("B2:B" & r) '把编号写入数组等待查找
m = 0 '初始化标志
n = 0 '初始化标志
p = 0 '初始化标志
For k = 1 To UBound(brr, 2) '循环日期下的数据,此处要求比较文档中的相同月份的日期必须连续。
If Month(Application.Text(brr(1, k), "0000-00-00")) = Month(DateAdd("m", 1, Date)) Then '如果日期的月份=下1个月的月份
If m = 0 Then '标志为0，也就是第一个出现的数据
min1 = k '出现的K存入min1中
m = 1 '修改标志，不让下次进入次条件语句中
Else
max1 = k '最后出现的存入max1中，用来以后循环数量和
End If
'下面的循环道理同上
ElseIf Month(Application.Text(brr(1, k), "0000-00-00")) = Month(DateAdd("m", 2, Date)) Then '如果日期的月份=下2个月的月份
If n = 0 Then
min2 = k
n = 1
Else
max2 = k
End If
ElseIf Month(Application.Text(brr(1, k), "0000-00-00")) = Month(DateAdd("m", 3, Date)) Then '如果日期的月份=下3个月的月份
If p = 0 Then
min3 = k
p = 1
Else
max3 = k
End If
End If
Next
ReDim crr(2 To r, 1 To 10) '重新定义crr数组的大小
For i = 2 To r '大循环，写入数组数组
crr(i, 1) = Split(d(frr(i - 1, 1)), "_")(0) '2.指定H列第一行名字为：收容数 根据对应的项目编码（B列）去“TxSEIK(比较)”套取相应的数据
crr(i, 5) = Split(d(frr(i - 1, 1)), "_")(1) '6.指定L列第一行名字为:上月（8-1=7）发行（8+1=9） 根据对应的项目编码（B列） 去TxSEIK(比较)里 套取数据{固定J列}
crr(i, 6) = Split(d(frr(i - 1, 1)), "_")(2) '7.指定M列第一行名字为：上月（8-1=7）发行（8+2=10） 根据对应的项目编码（B列）去TxSEIK(比较)里 套取数据{固定K列}
For k = min1 To max1 '利用上面循环出来满足月份条件的min 和max 进行循环
crr(i, 2) = crr(i, 2) + brr(i, k) '3.指定I列第一行名字为：当月的月份+1月（即9月）套取本身工作表R~FF列对应月份的 9/1--9/30 总量
Next
For k = min2 To max2
crr(i, 3) = crr(i, 3) + brr(i, k) '4.指定J列第一行名字为：当月的月份+2月 （即10月）套取本身工作表R~FF列对应月份的 10/1--10/31 总量
Next
For k = min3 To max3
crr(i, 4) = crr(i, 4) + brr(i, k) '5.指定K列第一行名字为：当月的月份+3月 （即11月）套取本身工作表R~FF列对应月份的 11/1--11/30 总量
Next
'===========(公式太多容易卡，这里是计算后的结果)==================
crr(i, 7) = (crr(i, 2) - crr(i, 5)) / crr(i, 5) '8.指定N列第一行名字为：当月份+1=9差异率 =(I2-L2)/L2 以第二行为例 向下填充整列公式
crr(i, 8) = (crr(i, 3) - crr(i, 6)) / crr(i, 6) '9.指定O列第一行名字为：当月份+2=10差异率 =(J2-M2)/M2 以第二行为例 向下填充整列公式
crr(i, 9) = (crr(i, 2) - crr(i, 5)) / crr(i, 1) '10.指定P列第一行名字为：当月份+1=9差异箱数 =(I2-L2)/H2 以第二行为例 向下填充整列公式
crr(i, 10) = (crr(i, 3) - crr(i, 6)) / crr(i, 1) '11.指定Q列第一行名字为：当月份+2=10差异箱数 =(J2-M2)/H2 以第二行为例 向下填充整列公式
'=========如果必须是填充公式，就把上面的部分注释掉，使用下面的部分======
'crr(i, 7) = "=(I" & i & "-L" & i & ")/L" & i
'crr(i, 8) = "=(J" & i & "-M" & i & ")/M" & i
'crr(i, 9) = "=(I" & i & "-L" & i & ")/H" & i
'crr(i, 10) = "=(J" & i & "-M" & i & ")/H" & i
'====================================================
Next
Range("H2:Q" & r) = crr '把大循环后crr的数据写入到H-Q这10列中
ActiveWorkbook.SaveAs Filename:=MyPath & Split(MyName1, ".")(0) & "(" & Month(Date) & "月份月度内示比较).xls", FileFormat:=xlExcel8 '另存为月份月度内示比较.xls
'-------------------------------第二步处理结束--------------------------
ActiveWindow.Close True '关闭 月份月度内示比较.xls
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "任务完成！"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2015-8-5 00:02
楼主