麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 項相分類重整 [打印本頁]

作者: mdr0465 時間: 2022-12-20 22:04 標題: 項相分類重整

各位大大,

請問我有一個總帳是所有資料都歸納在一個工作表, 但我想按照不同的編號(括號內的數字)複製在另一工作表和加上固定的項目名等稱, 每一個科目之間都會有一行空間相隔,

謝謝

作者: Andy2483 時間: 2022-12-21 11:00

回復 1# mdr0465

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

作者: Andy2483 時間: 2022-12-22 16:38

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

回復 1# mdr0465

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

執行結果:
[attach]35644[/attach]

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 時間: 2022-12-22 21:07

回復 3# Andy2483

Andy師兄,你好

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

,

作者: Andy2483 時間: 2022-12-23 09:00

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

回復 4# mdr0465

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

執行結果:
[attach]35647[/attach]

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 時間: 2022-12-23 12:34

回復 5# Andy2483

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

作者: lee88 時間: 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

複製代碼

作者: Andy2483 時間: 2022-12-28 16:13

回復 7# lee88

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

作者: Andy2483 時間: 2022-12-29 10:11

回復 7# lee88

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

執行結果:
[attach]35693[/attach]

輔助欄:
[attach]35694[/attach]

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 時間: 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

複製代碼

作者: Andy2483 時間: 2022-12-30 09:28

本帖最後由 Andy2483 於 2022-12-30 09:38 編輯

回復 10# lee88

謝謝前輩
學習到多欄儲存格進階篩選的方法,心得註解如下:

Option Explicit
Sub TEST_lee88()
Dim Sh As Worksheet, Rng As Range, i As Integer
'↑宣告變數:Sh是工作表變數,Rng是儲存格變數,i是短整數
Set Sh = Sheets("分類帳")
'↑令Sh是 "分類帳"工作表
With Sheets("結果")
'↑以下是關於 "結果"工作表的程序
.Cells.Clear
'↑清除全部工作表
Set Rng = .[a1]
'↑令Rng是 "結果"工作表的[A1]儲存格
Sh.Range("A:A").AdvancedFilter xlFilterCopy, , .[Z1], True
'↑令"分類帳"工作表 A欄做進階篩選到 "結果"工作表的[Z1]儲存格
'https://learn.microsoft.com/zh-tw/office/vba/api/excel.range.advancedfilter
Sh.Range("A1,d1").Copy .[aa1]
'↑令"分類帳"工作表[A1,D1]儲存格集複製到 "結果"工作表的[AA1]儲存格
.[ab2] = "=" & """<>" & " 本日合計"""
'填[摘要]入準則條件
'↑令"結果"工作表的[AB2]儲存格值是公式:="<> 本日合計"
i = 2
'↑令i這短整數是 2
Do While .[Z1].Cells(i) <> ""
'↑設無線迴圈!當 "結果"工作表的[Z1]儲存格向下i變數格的儲存格值不是 ""空字元,這條件下就繼續執行
'https://learn.microsoft.com/zh-tw/dotnet/visual-basic/language-reference/statements/do-loop-statement
   .Range("aa2," & Rng.Address) = .[Z1].Cells(i)
   '↑令[AA2]與Rng儲存格變數這兩個儲存格值是 "結果"工作表的[Z1]儲存格向下i變數格的儲存格值
   Sh.Range("B1:H1").Copy Rng.Cells(2)
   '↑令"分類帳"工作表[B1:H1]儲存格複製到 Rng儲存格變數的下一格
   Sh.Range("a:H").AdvancedFilter xlFilterCopy, .[aa1:ab2], Rng.Cells(2).Resize(1, 7)
   '進階篩選
   '↑令"分類帳"工作表[A:H]儲存格做進階篩選:
   '準則1:明細科目_幣別是Z欄各個i變數項目
   '準則2:摘要 "<> 本日合計"
   Set Rng = Rng.End(xlDown).Offset(2)
   '↑令Rng這儲存格變數是自身儲存格往下探到的最後有內容儲存格再往下邊移2格的儲存格
   i = i + 1
Loop
End With

作者: mdr0465 時間: 2022-12-31 20:05

回復 11# Andy2483
多謝兩位輩的悉心教導, 謝謝

作者: singo1232001 時間: 2023-3-4 09:32

回復 12# mdr0465

感謝借此題練習附上檔案

Sub 分類()
With CreateObject("adodb.connection"): V = Application.Version:
If V >= 12 Then V = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0; "
If V < 12 Then V = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0; "
.Open V & "Data Source=" & ThisWorkbook.FullName
Set s = Sheets("結果"): Set s1 = Sheets("分類帳")
ar = s1.Range("b1:H1")
tx = Join(Application.Index(ar, 1, 0), ",")
Set rs = .Execute("select distinct " & s1.[A1] & " from [分類帳$A1:A]")
rr = rs.getrows(, , "明細科目_幣別")
s.Cells.ClearContents
For Each Z In rr
r = s.Cells(Rows.Count, 1).End(3).Row + 2
s.Cells(r, 1) = Z
s.Cells(r + 1, 1).Resize(1, UBound(ar, 2)) = ar
q = "select " & tx & " from [分類帳$A1:H] where 明細科目_幣別 = '" & Z & "' and 摘要 not like '%本%日%合%計%' and 摘要 not like '%本%年%累%計%'"
s.Cells(r + 2, 1).CopyFromRecordset .Execute(q)
Next
s.Rows("1:2").Delete Shift:=xlUp
r = s.Cells(Rows.Count, 1).End(3).Row
s.Cells(1, 1).Resize(r, 7).Borders.LineStyle = 1
End With
End Sub

作者: Andy2483 時間: 2023-3-6 14:14

回復 13# singo1232001

謝謝前輩
請教前輩:
是不是要學過SQL、資料庫,才能了解此程式碼的意思?
謝謝前輩解惑

作者: singo1232001 時間: 2023-3-6 23:37

回復 14# Andy2483

是的
用vba 調用sql來處理excel某些資料整理的問題

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)