項相分類重整 - Excel程式區 - 麻辣家族討論版版

[發問] 項相分類重整

1^# 跳轉到 »

發表於 2022-12-28 15:27 | 顯示全部帖子

回復 5# Andy2483
試試進階篩選

Option Explicit
Dim Rng(1 To 5) As Range
Sub 項相分類重整()
設定
進階篩選
End Sub
Private Sub 設定()
Set Rng(1) = Sheets("分類帳").Range("A1").CurrentRegion
With Sheets("結果")
.Cells.Clear
Set Rng(2) = .[Z1] '存放明細科目_幣別攔不重復的項目
Set Rng(5) = .[A1] '存放每次篩選的位置
End With
Rng(1).Range("A1").Copy Rng(2)
Rng(1).AdvancedFilter xlFilterCopy, Rng(2).Cells.Resize(2), Rng(2), True ' "明細科目_幣別"篩選不重復的項目
Set Rng(3) = Rng(2).Offset(, 1) '篩選的準則範圍
Rng(1).Range("A1,D1").Copy Rng(3) '準則的欄位
Set Rng(4) = Rng(3).Offset(, 3) '指定被複製列的目標範圍
End Sub
Private Sub 進階篩選()
Dim i As Integer, R As Range
Rng(3).Range("B2") = "=" & """<>" & " 本日合計""" '填[摘要]入準則條件
i = 2
Do While Rng(2).Cells(i) <> ""
Rng(4).CurrentRegion.Clear
Rng(3).Range("A2") = Rng(2).Cells(i) '填入[明細科目_幣別]準則條件
Rng(1).AdvancedFilter xlFilterCopy, Rng(3).Resize(2, 2), Rng(4) '進階篩選'
Rng(5) = Rng(2).Cells(i).Value '標頭篩選的[明細科目_幣別]
Rng(4).CurrentRegion.Offset(, 1).Copy Rng(5).Offset(1) '資料的範圍 .Offset(, 1) 向右移動一攔 **不需要 [明細科目_幣別]欄
Set Rng(5) = Rng(5).End(xlDown).Offset(2)
i = i + 1
Loop
End Sub

複製代碼

2^#

發表於 2022-12-29 16:33 | 顯示全部帖子

回復 9# Andy2483
可搓摩一下

Option Explicit
Sub TEST()
Dim Sh As Worksheet, Rng As Range, i As Integer
Set Sh = Sheets("分類帳")
With Sheets("結果")
.Cells.Clear
Set Rng = .[a1]
Sh.Range("A:A").AdvancedFilter xlFilterCopy, , .[Z1], True '
Sh.Range("A1,d1").Copy .[aa1]
.[ab2] = "=" & """<>" & " 本日合計""" '填[摘要]入準則條件
i = 2
Do While .[Z1].Cells(i) <> ""
.Range("aa2," & Rng.Address) = .[Z1].Cells(i) '
Sh.Range("B1:H1").Copy Rng.Cells(2)
Sh.Range("a:H").AdvancedFilter xlFilterCopy, .[aa1:ab2], Rng.Cells(2).Resize(1, 7) '進階篩選'
Set Rng = Rng.End(xlDown).Offset(2)
i = i + 1
Loop
End With
End Sub

複製代碼

靜思自在 : 受人點水之恩，須當湧泉以報。