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

　暱稱: 厚臉皮的學生

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

11^# 跳轉到 »

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

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

TOP

mdr0465

中學生 Rank: 2

帖子: 167
主題: 48
精華: 0
積分: 253
點名: 6
作業系統: win7
軟體版本: ie
閱讀權限: 20
性別: 男
註冊時間: 2015-7-8
最後登錄: 2025-9-14

12^#

發表於 2022-12-31 20:05 | 只看該作者

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

TOP

singo1232001

　暱稱: 熱狗慶

中學生 Rank: 2

帖子: 354
主題: 5
精華: 0
積分: 387
點名: 0
作業系統: windows7
軟體版本: vba,vb,excel2007
閱讀權限: 20
性別: 男
註冊時間: 2017-1-8
最後登錄: 2024-8-2

論壇榮譽勳章論壇贊助勳章

13^#

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