|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 micch 于 2020-1-14 11:02 编辑
- Sub mictest()
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- For Each sh In Sheets
- If InStr("销售明细,回款明细,对账单模板,查询表", sh.Name) = 0 Then
- sh.Delete
- End If
- Next
- Dim d, arr(1 To 9999, 1 To 12), cd, xs, hk, dw$, ks@, js@, i&, k&, r&
- cd = Array(0, 1, 2, 5, 6, 10, 7, 11, 9, 1, 7, 8, 9)
- Set d = CreateObject("scripting.dictionary")
- Set sh = Sheets("对账单模板")
- xs = Sheets("销售明细").UsedRange
- hk = Sheets("回款明细").UsedRange
- With sh
- dw = Replace(Mid(.[a2].Value, 6), "公司", "")
- x = .[g2].Value
- ks = CDate((Mid(Left(x, InStr(x, "-") - 1), 6)))
- js = CDate(Mid(x, InStr(x, "-") + 1))
- End With
- For i = 2 To UBound(xs)
- If InStr(xs(i, 2), dw) And xs(i, 1) >= ks And xs(i, 1) <= js Then
- d(xs(i, 2)) = d(xs(i, 2)) & " " & i
- End If
- Next i
- For i = 2 To UBound(hk)
- If InStr(hk(i, 3), dw) And hk(i, 1) >= ks And hk(i, 1) <= js Then
- d(hk(i, 3)) = d(hk(i, 3)) & ";" & i
- End If
- Next i
- For Each x In d.keys
- Sheets.Add after:=Sheets(Sheets.Count)
- With Sheets(Sheets.Count)
- .Name = x
- sh.[a1:l4].Copy .[a1]
- .[a2] = "收货单位:" & x
- ar = Split(d(x))
- k = 0
- For i = 1 To UBound(ar)
- k = k + 1
- For j = 1 To 8
- arr(k, j) = xs(Val(ar(i)), cd(j))
- Next j, i
- r = k
- ar = Split(ar(UBound(ar)), ";")
- k = 0
- For i = 1 To UBound(ar)
- k = k + 1
- For j = 9 To 12
- arr(k, j) = hk(Val(ar(i)), cd(j))
- Next j, i
- r = IIf(k > r, k, r)
- .[a5].Resize(r, 12) = arr
- sh.[a33:l39].Copy .Cells(r + 6, 1)
- End With
- Next
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|