- 帖子
- 353
- 主題
- 5
- 精華
- 0
- 積分
- 386
- 點名
- 0
- 作業系統
- windows7
- 軟體版本
- vba,vb,excel2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2017-1-8
- 最後登錄
- 2024-5-4
 
|
回復 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 |
-
-
分類帳.zip
(176.6 KB)
|
發表於 2023-3-4 09:32
| 