返回列表 上一主題 發帖

[發問] Debtor aging report - Sub total

[發問] 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要有框線

出來的效果就好像手動一般, (資料-->小計-->分組小欄位).
但需要符合三種條件, 才能成為一組.

謝謝幫忙

SAMPLE.rar (4.32 KB)

回復 1# cdcc
  1. Sub Ex1()
  2.     Dim i%, Rng As Range
  3.     With Sheet1
  4.          '1 篩選
  5.          Range("A4").Sort Key1:=Range("E5"), Order1:=xlAscending, Key2:=Range("A5"), Order2:=xlAscending, Header:=xlYes
  6.         i = 5
  7.         Do While .Cells(i, "A").End(xlDown).Row <> Rows.Count
  8.             If .Cells(i, "A") & .Cells(i, "A") <> "" And .Cells(i + 1, "A") & .Cells(i + 1, "A") <> "" Then
  9.                 If .Cells(i, "A") & .Cells(i, "A") <> .Cells(i + 1, "A") & .Cells(i + 1, "A") Then
  10.                     i = i + 1
  11.                     Set Rng = .Range(.Cells(i, "A"), .Cells(Rows.Count, "G").End(xlUp))
  12.                     '2 移動範圍
  13.                     Rng.Cut Rng.Offset(2)
  14.                     i = i + 1
  15.                 End If
  16.             End If
  17.             i = i + 1
  18.         Loop
  19.         Set Rng = .Range("G5", .Cells(Rows.Count, "G").End(xlUp))
  20.         For Each E In Rng.SpecialCells(xlCellTypeConstants).Areas
  21.             E(E.Count + 1, 0).Value = "Sub Total:"
  22.             '3 給值
  23.             With E(E.Count + 1)
  24.                 .Value = Application.Sum(E)
  25.                 .Borders(3).LineStyle = 1
  26.                 .Borders(3).Weight = 2
  27.                 .Borders(4).LineStyle = 1
  28.                 .Borders(4).Weight = 3
  29.             End With
  30.         Next
  31.     End With
  32.     Set Rng = Nothing
  33. End Sub
複製代碼
  1. Sub Ex2()   '陣列方式
  2.     Dim D As Object, Rng As Range, R, AR
  3.     Set D = CreateObject("Scripting.dictionary")
  4.     With Sheet1
  5.          Range("A4").Sort Key1:=Range("E5"), Order1:=xlAscending, Key2:=Range("A5"), Order2:=xlAscending, Header:=xlYes
  6.         Set Rng = .Range(.[a5], .[a5].End(xlToRight).End(xlDown))
  7.     End With
  8.     For Each R In Rng.Rows
  9.         If D.Exists(R.Cells(1, 1) & R.Cells(1, 5)) Then
  10.             AR = D(R.Cells(1, 1) & R.Cells(1, 5))
  11.             ReDim Preserve AR(1 To UBound(AR), 1 To UBound(AR, 2) + 1)
  12.             For i = 1 To UBound(AR)
  13.                 AR(i, UBound(AR, 2)) = R.Cells(i)
  14.             Next
  15.             D(R.Cells(1, 1) & R.Cells(1, 5)) = AR
  16.         Else
  17.             D(R.Cells(1, 1) & R.Cells(1, 5)) = Application.Transpose(R.Value)
  18.         End If
  19.     Next
  20.     With Sheet1
  21.          .Range(.[a5], .Cells(Rows.Count, "G")).Clear
  22.          Set Rng = .[a5]
  23.     End With
  24.     For Each R In D.KEYS
  25.         Rng.Resize(UBound(D(R), 2), 7) = Application.Transpose(D(R))
  26.         With Rng.Cells(UBound(D(R), 2) + 1, 5)
  27.             .Value = "Sub Total:"
  28.             With .Offset(, 1)
  29.                 .Value = Application.Sum(Application.Index(D(R), 6))
  30.                 .Borders(3).LineStyle = xlContinuous
  31.                 .Borders(3).Weight = xlThin
  32.                 .Borders(4).LineStyle = xlContinuous
  33.                 .Borders(4).Weight = 3
  34.             End With
  35.         End With
  36.         Set Rng = Rng.Cells(1).Offset(UBound(D(R), 2) + 2)
  37.      Next
  38.     Set D = Nothing
  39.     Set Rng = Nothing
  40. End Sub
複製代碼

TOP

回復 3# GBKEE


謝謝回覆

    條件:
1)Customer ID
2)Currency
3)修正 Remark 應該 - <=30 OR >30 兩類別, 其實是代表 over due period

但首先Customer ID需要 由小至大順序顯示
其次是Currency
最後是 Remark

符合所有條件, 才成為一小組類別

感謝回覆

TOP

回復 4# cdcc
3)修正 Remark 應該 - <=30 OR >30 兩類別, 其實是代表 over due period
條件要一次說清楚,雖有範例也要說出重點
  1. Sub Ex2()   '陣列方式
  2.     Dim D As Object, Rng As Range, R, AR, Msg As Boolean
  3.     Set D = CreateObject("Scripting.dictionary")
  4.     With Sheet1
  5.         .Range("A4").Sort Key1:=.Range("A5"), Order1:=xlAscending, Key2:=.Range("E5"), Order2:=xlAscending, Key3:=.Range("G5"), Order3:=xlAscending, Header:=xlYes
  6.         Set Rng = .Range(.[a5], .[a5].End(xlToRight).End(xlDown))
  7.     End With
  8.     For Each R In Rng.Rows
  9.         Msg = IIf(R.Cells(1, 7) <= 30, True, False)
  10.         If D.Exists(R.Cells(1, 1) & R.Cells(1, 5) & Msg) Then
  11.             AR = D(R.Cells(1, 1) & R.Cells(1, 5) & Msg)
  12.             ReDim Preserve AR(1 To UBound(AR), 1 To UBound(AR, 2) + 1)
  13.             For i = 1 To UBound(AR)
  14.                 AR(i, UBound(AR, 2)) = R.Cells(i)
  15.             Next
  16.             D(R.Cells(1, 1) & R.Cells(1, 5) & Msg) = AR
  17.         Else
  18.             D(R.Cells(1, 1) & R.Cells(1, 5) & Msg) = Application.Transpose(R.Value)
  19.         End If
  20.     Next
  21.     With Sheet1
  22.          .Range(.[a5], .Cells(Rows.Count, "G")).Clear
  23.          Set Rng = .[a5]
  24.     End With
  25.     For Each R In D.KEYS
  26.         Rng.Resize(UBound(D(R), 2), 7) = Application.Transpose(D(R))
  27.         
  28.         With Rng.Cells(UBound(D(R), 2) + 1, 5)
  29.             .Value = "Sub Total:"
  30.             With .Offset(, 1)
  31.                 .Value = Application.Sum(Application.Index(D(R), 6))
  32.                 .Borders(3).LineStyle = xlContinuous
  33.                 .Borders(3).Weight = xlThin
  34.                 .Borders(4).LineStyle = xlContinuous
  35.                 .Borders(4).Weight = 3
  36.             End With
  37.         End With
  38.         Set Rng = Rng.Cells(1).Offset(UBound(D(R), 2) + 2)
  39.      Next
  40.     Set D = Nothing
  41.     Set Rng = Nothing
  42. End Sub
複製代碼

TOP

回復 5# 老夏


    的確是多了兩筆記錄.
    謝謝提點, 指出錯處.
    下次會依規修正後才提問.

TOP

回復 4# GBKEE


    OK!!
   真的很方便, 可以很快完成.
  我是初學者, 需要時間了解所寫的VBA內容.
  如果我有不明白, 希望日後可以詳加解釋

謝謝

TOP

  1. Sub nn()
  2. Set d = CreateObject("Scripting.dictionary")
  3. Set d1 = CreateObject("Scripting.dictionary")
  4. Dim Ar()
  5. Range("A4").CurrentRegion.Sort key1:=[A5], Header:=xlYes
  6. A = [A4].CurrentRegion.Offset(1)
  7. For i = 1 To UBound(A)
  8. If IsEmpty(d(A(i, 1) & A(i, 5))) Then
  9.     d(A(i, 1) & A(i, 5)) = Array(Application.Index(A, i))
  10.     d1(A(i, 1) & A(i, 5)) = d1(A(i, 1) & A(i, 5)) + 1
  11.     Else
  12.     Ar = d(A(i, 1) & A(i, 5))
  13.     ReDim Preserve Ar(d1(A(i, 1) & A(i, 5)))
  14.     Ar(d1(A(i, 1) & A(i, 5))) = Array(Application.Index(A, i))
  15.     d(A(i, 1) & A(i, 5)) = Ar
  16.     d1(A(i, 1) & A(i, 5)) = d1(A(i, 1) & A(i, 5)) + 1
  17.   End If
  18. Next
  19. r = 5
  20. [A4].CurrentRegion.Offset(1) = ""
  21. For Each ky In d.keys
  22. If ky <> "" Then
  23.    Cells(r, 1).Resize(UBound(d(ky)) + 1, 7) = Application.Transpose(Application.Transpose(d(ky)))
  24.    Cells(r + UBound(d(ky)) + 1, 5) = "Sub Total:"
  25.    Cells(r + UBound(d(ky)) + 1, 6) = Application.Sum(Application.Index(d(ky), , 6))
  26.    r = r + UBound(d(ky)) + 3
  27. End If
  28. Next
  29. End Su
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 君子為目標,小人為目的。
返回列表 上一主題