- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
回復 1# macro0029
試試看- Option Explicit
- Sub Ex()
- Dim Sh As Worksheet, Rng As Range, xRng As Range, i As Long
- Set Sh = Sheets("總表") '**資料庫的工作表
- Set xRng = Sh.Range("a1", Sh.Range("a1").End(xlToRight).End(xlDown)) '**資料庫的範圍
- Set Rng = Sh.Cells(1, Columns.Count - 1).Resize(2, 2) '**進階篩選的準則範圍
- Rng.Range("B1") = Sh.Range("A1").End(xlToRight) '**進階篩選的準則欄位 [類別]
- Rng.Range("A1") = Sh.Range("A1") & "A" '**進階篩選的準則欄位 [製票機構A]
- '*PS:重要** 計算式準則時,準則的欄位不可與資料庫的欄位同****
- Rng.Range("B2") = "收支調整" '**進階篩選的準則欄位 [類別] 條件
- With Sheets("主題1")
- .Cells.Clear
- '***[製票機構]此欄資料的數字為文字格式****
- Rng.Range("A2") = "=製票機構<>""7070""" '**進階篩選的準則欄位 [製票機構A] 條件
- xRng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Rng, CopyToRange:=.[a1]
- '**xRng.AdvancedFilter:資料庫的進階篩選方法
- '**參數 xlFilterCopy 資料庫的進階篩選動作
- '**參數 CriteriaRange :準則範圍
- '**參數 CopyToRange: 如果 Action 為 xlFilterCopy，此引數即為複製列的目的範圍。否則，會忽略此引數。
- .Range("B:C").Delete '(發動機構,列帳機構) 刪除
- .Range("E1") = "會計科目"
- i = 2
- Do
- .Cells(i, "E") = .Cells(i, "E") & .Cells(i, "F") '（總，細），合併至E欄（會計科目）
- i = i + 1
- Loop Until .Cells(i, "E") = ""
- .Range("E:E").NumberFormatLocal = "@" '設為文字格式
- .Range("F:F").Delete
- End With
- With Sheets("主題2")
- .Cells.Clear
- ' Rng.Range("A2") = "=製票機構=""7070"""
- xRng.AdvancedFilter xlFilterCopy, Rng, .[a1]
- .Range("b:c").Delete
- .Range("E1") = "會計科目"
- i = 2
- Do
- .Cells(i, "E") = .Cells(i, "E") & .Cells(i, "F")
- i = i + 1
- Loop Until .Cells(i, "E") = ""
- .Range("E:E").NumberFormatLocal = "@"
- .Range("F:F").Delete
- End With
- Rng.Clear
- End Sub
|
|
發表於 2018-1-5 14:22
| 