標題:
[發問]
Debtor aging report - Sub total
[打印本頁]
作者:
cdcc
時間:
2011-5-15 01:10
標題:
Debtor aging report - Sub total
本帖最後由 cdcc 於 2011-5-15 22:49 編輯
將DATA分類, 製成Debtor aging report
條件:
1)Customer ID
2)Currency
3)Remark - <30 OR >=30
每一組都要有SUB TOTAL AMOUNT
格式方面:
1) SUB TOTAL(文字) 要在COLUMN E出現
2) SUB TOTAL 之下需要有一行空白的ROW
3)SUB TOTAL AMOUNT要有框線
出來的效果就好像手動一般, (資料-->小計-->分組小欄位).
但需要符合三種條件, 才能成為一組.
謝謝幫忙
作者:
GBKEE
時間:
2011-5-15 12:27
回復
1#
cdcc
Sub Ex1()
Dim i%, Rng As Range
With Sheet1
'1 篩選
Range("A4").Sort Key1:=Range("E5"), Order1:=xlAscending, Key2:=Range("A5"), Order2:=xlAscending, Header:=xlYes
i = 5
Do While .Cells(i, "A").End(xlDown).Row <> Rows.Count
If .Cells(i, "A") & .Cells(i, "A") <> "" And .Cells(i + 1, "A") & .Cells(i + 1, "A") <> "" Then
If .Cells(i, "A") & .Cells(i, "A") <> .Cells(i + 1, "A") & .Cells(i + 1, "A") Then
i = i + 1
Set Rng = .Range(.Cells(i, "A"), .Cells(Rows.Count, "G").End(xlUp))
'2 移動範圍
Rng.Cut Rng.Offset(2)
i = i + 1
End If
End If
i = i + 1
Loop
Set Rng = .Range("G5", .Cells(Rows.Count, "G").End(xlUp))
For Each E In Rng.SpecialCells(xlCellTypeConstants).Areas
E(E.Count + 1, 0).Value = "Sub Total:"
'3 給值
With E(E.Count + 1)
.Value = Application.Sum(E)
.Borders(3).LineStyle = 1
.Borders(3).Weight = 2
.Borders(4).LineStyle = 1
.Borders(4).Weight = 3
End With
Next
End With
Set Rng = Nothing
End Sub
複製代碼
Sub Ex2() '陣列方式
Dim D As Object, Rng As Range, R, AR
Set D = CreateObject("Scripting.dictionary")
With Sheet1
Range("A4").Sort Key1:=Range("E5"), Order1:=xlAscending, Key2:=Range("A5"), Order2:=xlAscending, Header:=xlYes
Set Rng = .Range(.[a5], .[a5].End(xlToRight).End(xlDown))
End With
For Each R In Rng.Rows
If D.Exists(R.Cells(1, 1) & R.Cells(1, 5)) Then
AR = D(R.Cells(1, 1) & R.Cells(1, 5))
ReDim Preserve AR(1 To UBound(AR), 1 To UBound(AR, 2) + 1)
For i = 1 To UBound(AR)
AR(i, UBound(AR, 2)) = R.Cells(i)
Next
D(R.Cells(1, 1) & R.Cells(1, 5)) = AR
Else
D(R.Cells(1, 1) & R.Cells(1, 5)) = Application.Transpose(R.Value)
End If
Next
With Sheet1
.Range(.[a5], .Cells(Rows.Count, "G")).Clear
Set Rng = .[a5]
End With
For Each R In D.KEYS
Rng.Resize(UBound(D(R), 2), 7) = Application.Transpose(D(R))
With Rng.Cells(UBound(D(R), 2) + 1, 5)
.Value = "Sub Total:"
With .Offset(, 1)
.Value = Application.Sum(Application.Index(D(R), 6))
.Borders(3).LineStyle = xlContinuous
.Borders(3).Weight = xlThin
.Borders(4).LineStyle = xlContinuous
.Borders(4).Weight = 3
End With
End With
Set Rng = Rng.Cells(1).Offset(UBound(D(R), 2) + 2)
Next
Set D = Nothing
Set Rng = Nothing
End Sub
複製代碼
作者:
cdcc
時間:
2011-5-15 16:56
回復
3#
GBKEE
謝謝回覆
條件:
1)Customer ID
2)Currency
3)修正 Remark 應該 -
<=30 OR >30
兩類別, 其實是代表 over due period
但首先Customer ID需要 由小至大順序顯示
其次是Currency
最後是 Remark
符合所有條件, 才成為一小組類別
感謝回覆
作者:
GBKEE
時間:
2011-5-15 20:33
回復
4#
cdcc
3)修正 Remark 應該 - <=30 OR >30 兩類別, 其實是代表 over due period
條件要一次說清楚,雖有範例也要說出重點
Sub Ex2() '陣列方式
Dim D As Object, Rng As Range, R, AR, Msg As Boolean
Set D = CreateObject("Scripting.dictionary")
With Sheet1
.Range("A4").Sort Key1:=.Range("A5"), Order1:=xlAscending, Key2:=.Range("E5"), Order2:=xlAscending, Key3:=.Range("G5"), Order3:=xlAscending, Header:=xlYes
Set Rng = .Range(.[a5], .[a5].End(xlToRight).End(xlDown))
End With
For Each R In Rng.Rows
Msg = IIf(R.Cells(1, 7) <= 30, True, False)
If D.Exists(R.Cells(1, 1) & R.Cells(1, 5) & Msg) Then
AR = D(R.Cells(1, 1) & R.Cells(1, 5) & Msg)
ReDim Preserve AR(1 To UBound(AR), 1 To UBound(AR, 2) + 1)
For i = 1 To UBound(AR)
AR(i, UBound(AR, 2)) = R.Cells(i)
Next
D(R.Cells(1, 1) & R.Cells(1, 5) & Msg) = AR
Else
D(R.Cells(1, 1) & R.Cells(1, 5) & Msg) = Application.Transpose(R.Value)
End If
Next
With Sheet1
.Range(.[a5], .Cells(Rows.Count, "G")).Clear
Set Rng = .[a5]
End With
For Each R In D.KEYS
Rng.Resize(UBound(D(R), 2), 7) = Application.Transpose(D(R))
With Rng.Cells(UBound(D(R), 2) + 1, 5)
.Value = "Sub Total:"
With .Offset(, 1)
.Value = Application.Sum(Application.Index(D(R), 6))
.Borders(3).LineStyle = xlContinuous
.Borders(3).Weight = xlThin
.Borders(4).LineStyle = xlContinuous
.Borders(4).Weight = 3
End With
End With
Set Rng = Rng.Cells(1).Offset(UBound(D(R), 2) + 2)
Next
Set D = Nothing
Set Rng = Nothing
End Sub
複製代碼
作者:
cdcc
時間:
2011-5-15 22:26
回復
5#
老夏
的確是多了兩筆記錄.
謝謝提點, 指出錯處.
下次會依規修正後才提問.
作者:
cdcc
時間:
2011-5-15 22:37
回復
4#
GBKEE
OK!!
真的很方便, 可以很快完成.
我是初學者, 需要時間了解所寫的VBA內容.
如果我有不明白, 希望日後可以詳加解釋
謝謝
作者:
Hsieh
時間:
2011-5-16 00:04
Sub nn()
Set d = CreateObject("Scripting.dictionary")
Set d1 = CreateObject("Scripting.dictionary")
Dim Ar()
Range("A4").CurrentRegion.Sort key1:=[A5], Header:=xlYes
A = [A4].CurrentRegion.Offset(1)
For i = 1 To UBound(A)
If IsEmpty(d(A(i, 1) & A(i, 5))) Then
d(A(i, 1) & A(i, 5)) = Array(Application.Index(A, i))
d1(A(i, 1) & A(i, 5)) = d1(A(i, 1) & A(i, 5)) + 1
Else
Ar = d(A(i, 1) & A(i, 5))
ReDim Preserve Ar(d1(A(i, 1) & A(i, 5)))
Ar(d1(A(i, 1) & A(i, 5))) = Array(Application.Index(A, i))
d(A(i, 1) & A(i, 5)) = Ar
d1(A(i, 1) & A(i, 5)) = d1(A(i, 1) & A(i, 5)) + 1
End If
Next
r = 5
[A4].CurrentRegion.Offset(1) = ""
For Each ky In d.keys
If ky <> "" Then
Cells(r, 1).Resize(UBound(d(ky)) + 1, 7) = Application.Transpose(Application.Transpose(d(ky)))
Cells(r + UBound(d(ky)) + 1, 5) = "Sub Total:"
Cells(r + UBound(d(ky)) + 1, 6) = Application.Sum(Application.Index(d(ky), , 6))
r = r + UBound(d(ky)) + 3
End If
Next
End Su
複製代碼
歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)
