[發問] 項相分類重整

mdr0465

各位大大,

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

謝謝

singo1232001

回復 14# Andy2483


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

Andy2483

回復 13# singo1232001


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

singo1232001

回復 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

mdr0465

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

Andy2483

回復 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

lee88

回復 9# Andy2483
可搓摩一下

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

複製代碼

Andy2483

回復 7# lee88


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

執行結果:

下載 (213.28 KB)

2022-12-29 10:09

輔助欄:

下載 (188.91 KB)

2022-12-29 10:09

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

Andy2483

回復 7# lee88


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

下載 (213.28 KB)

2022-12-28 16:12

lee88

回復 5# Andy2483
試試進階篩選

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

複製代碼