[發問] 項相分類重整

　暱稱: 厚臉皮的學生

帖子: 1447
主題: 40
精華: 0
積分: 1471
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2025-3-24

2^#

發表於 2022-12-21 11:00 | 只看該作者

回復 1# mdr0465

謝謝前輩發表此主題與範例檔
後學研究過以下連結帖比這帖複雜,請前輩研究看看
http://forum.twbts.com/viewthrea ... a=pageD3&page=1

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

　暱稱: 厚臉皮的學生

帖子: 1447
主題: 40
精華: 0
積分: 1471
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2025-3-24

3^#

發表於 2022-12-22 16:38 | 只看該作者

本帖最後由 Andy2483 於 2022-12-22 16:47 編輯

回復 1# mdr0465

祝各位前輩冬至平安喜樂
後學今天休假,臨時被召回處裡事情,看了一下這帖
昨天有研究了前輩需求情境,今天測試了一下,先提供給前輩試試看,是否符合需求
先回家了,前輩的留言明天才能回復
請前輩們指導

執行結果:

Option Explicit
Sub 項相分類重整_20221222_1()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim Arr, i&, j&, Brr, Y, N, Ra, Sh
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = Sheets("結果")
Arr = Range([分類帳!H1], [分類帳!A1].Cells(Rows.Count, 1).End(xlUp))
With Sheets.Add
With .[A1].Resize(UBound(Arr), UBound(Arr, 2))
   .Value = Arr
   .Sort _
   KEY1:=.Item(1), Order1:=xlAscending, _
   Key2:=.Item(2), Order2:=xlAscending, _
   Header:=xlYes, Orientation:=xlTopToBottom
   Arr = .Value
End With
.Delete
End With
For i = 1 To UBound(Arr)
Y(Arr(i, 1)) = ""
Next
ReDim Brr(1 To UBound(Arr) + Y.Count * 3, 1 To UBound(Arr, 2))
Set Ra = Sh.[A1:H1]
For i = 2 To UBound(Arr)
If Arr(i, 1) <> Arr(i - 1, 1) Then
   N = IIf(i = 2, N + 1, N + 2)
   Set Ra = Union(Ra, Range(Sh.Cells(N, 1), Sh.Cells(N, 8)))
   Brr(N, 2) = Arr(i, 1)
   N = N + 1
   Set Ra = Union(Ra, Range(Sh.Cells(N, 1), Sh.Cells(N, 8)))
   For j = 1 To UBound(Arr, 2)
      Brr(N, j) = Arr(1, j)
   Next
End If

111
N = N + 1
Set Ra = Union(Ra, Range(Sh.Cells(N, 1), Sh.Cells(N, 8)))
For j = 1 To UBound(Arr, 2)
   Brr(N, j) = Arr(i, j)
Next
Brr(N, 2) = "'" & Format(Brr(N, 2), "yyyy-mm-dd")
Brr(N, 3) = "'" & Brr(N, 3)
Next
Sh.UsedRange.ClearContents
Sh.Cells.Borders.LineStyle = 0
Ra.Borders.LineStyle = 1
Sh.[A1].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
Set Y = Nothing
Set Arr = Nothing
Set Brr = Nothing
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

mdr0465

帖子: 163
主題: 45
精華: 0
積分: 246
點名: 1
作業系統: win7
軟體版本: ie
閱讀權限: 20
性別: 男
註冊時間: 2015-7-8
最後登錄: 2025-3-8

4^#

發表於 2022-12-22 21:07 | 只看該作者

回復 3# Andy2483

Andy師兄,你好

謝謝你的幫忙
這正是我想要的結果,但可不可以再修改一些內容, 我想將所有的" 本日合計" 和"本年累計" 都刪除,謝謝幫忙修改程式

,

　暱稱: 厚臉皮的學生

帖子: 1447
主題: 40
精華: 0
積分: 1471
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2025-3-24

5^#

發表於 2022-12-23 09:00 | 只看該作者

本帖最後由 Andy2483 於 2022-12-23 09:11 編輯

回復 4# mdr0465

謝謝前輩回復
今天複習修改了一下,請前輩再試試看,心得註解請參考
請各位前輩指導,謝謝

執行結果:

Option Explicit
Sub 項相分類重整_20221222_1()
Application.DisplayAlerts = False
'↑不要問是不是真的要刪除工作表!乾脆點!
Application.ScreenUpdating = False
'↑螢幕不要跟著程序做變化!偷偷做就好了
Dim i&, j&, N&, St$, Arr, Brr, Y, Z, Ra, Sh
'↑宣告變數:(i,j,N)是長整數變數,St是字串變數,其他是通用型變數
Set Y = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
'↑令Y,Z各是字典
Set Sh = Sheets("結果")
'↑令Sh是 "結果"工作表
Arr = Range([分類帳!H1], [分類帳!A1].Cells(Rows.Count, 1).End(xlUp))
'↑令Arr是二維陣列!倒入從 "分類帳"工作表的[H1]到該表的A欄最後一個有內容儲存格之間,
'擴展成為最小方正區域儲存格的值
With Sheets.Add
'↑以下是有關於新增工作表的程序
With .[A1].Resize(UBound(Arr), UBound(Arr, 2))
'↑以下是有關於新增工作表從[A1]擴展縱向Arr陣列最大列號數,橫向Arr陣列最大欄號數,
'這些儲存格的程序
   .Value = Arr
   '↑儲存格值以 Arr陣列值倒進去
   .Sort _
   KEY1:=.Item(1), Order1:=xlAscending, _
   Key2:=.Item(2), Order2:=xlAscending, _
   Header:=xlYes, Orientation:=xlTopToBottom
   '↑令以第1欄做第一層做有標列的上下順排序,第2欄同時做第二層上下順排序
   Arr = .Value
   '↑令Arr陣列倒掉原來的值,裝入這排序好的儲存格值
End With
.Delete
'↑令這新增工作表刪除
End With
'我想將所有的" 本日合計" 和"本年累計" 都刪除
St = "/本日合計/本年累計/關鍵字|/關鍵字|/"
'↑令St這字串變數是雙引號裡的這些字,關鍵字|是用來給使用者追加的
For i = 1 To UBound(Arr)
'↑設順迴圈!i從1到Arr陣列最大列號數
Y(Arr(i, 1)) = ""
'↑令以迴圈列第1欄Arr陣列值當key,item是空字元,放入Y字典裡,
'這是要統計共有幾種明細科目,才知道要增加多少標題列
If InStr(St, "/" & Replace(Arr(i, 4), " ", "") & "/") <> 0 Then
'↑如果用InStr()函式判斷是不等於 0,怎麼判斷?
'先用Replace()函式將i迴圈列第4欄Arr陣列值,用""空字元置換掉" "空白字元,
'再用"/"符號在前後包住這字串,以免誤判
'去比對St字串變數裡有沒有包含這串字
'https://learn.microsoft.com/zh-tw/office/vba/language/reference/user-interface-help/instr-function
   Z("合計累計") = Z("合計累計") + 1
   '↑令以"合計累計"字串當key,item累加 1
End If
Next
ReDim Brr(1 To UBound(Arr) + Y.Count * 3 - 1 - Z("合計累計"), 1 To UBound(Arr, 2))
'↑宣告Brr陣列的範圍大小,縱向從1到Arr陣列最大索引列號數+Y字典key數量*3,減1,
'再減掉 "合計累計"字串當key查Z字典得到的item值
'橫向從1到Arr陣列最大索引欄號數
Set Ra = Sh.[A1:H1]
'↑令Ra這通用型變數是 Sh工作表變數裡的[A1:H1]儲存格
For i = 2 To UBound(Arr)
'↑設外順迴圈!i從2到Arr陣列最大列號數
If Arr(i, 1) <> Arr(i - 1, 1) Then
'↑如果i迴圈列第1欄Arr陣列值不等於(i-1)迴圈列第1欄Arr陣列值
   N = IIf(i = 2, N + 1, N + 2)
   '↑令N這長整數變數的值用 IIf()函式決定,
   '如果i迴圈數是 2時N = N + 1,否則N = N + 2
   Set Ra = Union(Ra, Range(Sh.Cells(N, 1), Sh.Cells(N, 8)))
   '↑令Ra這通用型變數用Union()函式累積儲存格集,
   '規則是Ra自身再加入從"結果"工作表 N列第1欄儲存格到該表N列第8欄儲存格,
   '這兩格之間的所有儲存格
   Brr(N, 2) = Arr(i, 1)
   '↑令N變數列第2欄Brr陣列值是 i迴圈列第1欄Arr陣列值 (明細科目)
   N = N + 1
   '↑令N這長整數變數X累加 1 (加1列)
   Set Ra = Union(Ra, Range(Sh.Cells(N, 1), Sh.Cells(N, 8)))
   '↑同上
   For j = 1 To UBound(Arr, 2)
   '↑設內順迴圈!j從1到Arr陣列最大欄號數
      Brr(N, j) = Arr(1, j)
      '↑令N變數列第j迴圈欄Brr陣列值是第1列第j迴圈欄Arr陣列值
   Next
End If
If InStr(St, "/" & Replace(Arr(i, 4), " ", "") & "/") <> 0 Then
'↑同上
   GoTo Hi
   '↑就去找 Hi
End If
N = N + 1
'↑同上
Set Ra = Union(Ra, Range(Sh.Cells(N, 1), Sh.Cells(N, 8)))
'↑同上
For j = 1 To UBound(Arr, 2)
'↑同上
   Brr(N, j) = Arr(i, j)
   '↑令N變數列第j迴圈欄Brr陣列值是第i迴圈第j迴圈欄Arr陣列值
Next
Brr(N, 2) = "'" & Format(Brr(N, 2), "yyyy-mm-dd")
'↑令N變數列第2欄Brr陣列值是"'" 符號連接自身日期轉為字串,
'以"yyyy-mm-dd"方式呈現
Brr(N, 3) = "'" & Brr(N, 3)
'↑令N變數列第3欄Brr陣列值是"'" 符號連接自身
Hi:
'Hi在這裡
Next
Sh.UsedRange.ClearContents
'↑令Sh變數工作表有使用的儲存格最小方正區域儲存格內容清除
Sh.Cells.Borders.LineStyle = 0
'↑令Sh變數工作表全部的格線都不要
Ra.Borders.LineStyle = 1
'↑令Ra這儲存格集的格線是細實線
Sh.[A1].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
'↑令Sh變數工作表從[A1]擴展縱向:Brr陣列縱向最大索引列號數,
'橫向:Brr陣列橫向最大索引欄號數,這範圍儲存格以 Brr陣列值倒入
'完工了
Set Y = Nothing
Set Z = Nothing
Set Arr = Nothing
Set Brr = Nothing
'工具容器要收一收,釋放掉變數
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

mdr0465

帖子: 163
主題: 45
精華: 0
積分: 246
點名: 1
作業系統: win7
軟體版本: ie
閱讀權限: 20
性別: 男
註冊時間: 2015-7-8
最後登錄: 2025-3-8

6^#

發表於 2022-12-23 12:34 | 只看該作者

回復 5# Andy2483

Andy師兄,
萬分感謝你的幫忙和詳細的解讀, 謝謝你

lee88

帖子: 13
主題: 0
精華: 0
積分: 63
點名: 0
作業系統: win10
軟體版本: office 365
閱讀權限: 20
性別: 女
註冊時間: 2022-2-1
最後登錄: 2024-11-20

7^#

發表於 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

複製代碼

　暱稱: 厚臉皮的學生

帖子: 1447
主題: 40
精華: 0
積分: 1471
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2025-3-24

8^#

發表於 2022-12-28 16:13 | 只看該作者

回復 7# lee88

謝謝前輩指導
後學是錄製巨集學起的,都以眼見為憑修改巨集以符合需求,不知道可以這樣運用
先謝謝前輩指導,後學依循前輩註解研究看看
執行結果:

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

　暱稱: 厚臉皮的學生

帖子: 1447
主題: 40
精華: 0
積分: 1471
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2025-3-24

9^#

發表於 2022-12-29 10:11 | 只看該作者

回復 7# lee88

謝謝前輩指導
後學今天練習將Rng(1 To 5) As Range 用Y字典裝盛

執行結果:

輔助欄:

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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

lee88

帖子: 13
主題: 0
精華: 0
積分: 63
點名: 0
作業系統: win10
軟體版本: office 365
閱讀權限: 20
性別: 女
註冊時間: 2022-2-1
最後登錄: 2024-11-20

10^#

發表於 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

複製代碼