帖子: 8
主題: 5
精華: 0
積分: 63
點名: 0
作業系統: WIN7
軟體版本: 2007
閱讀權限: 20
註冊時間: 2017-3-14
最後登錄: 2023-8-21

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2018-1-4 15:21 | 只看該作者

[發問] 總表匯集試問

我第一個是這樣寫，但是跳第二個偵測最下列的部分一直有問題
Sheets("主題1").Select
ActiveSheet.Range("A2", ActiveSheet.Range("B2").End(xlDown)).Select
Selection.Copy
Sheets("總表").Select
Range("A2").Select
ActiveSheet.Paste
Range("a65536").End(xlUp).Select
Range("A" & ActiveCell.Row + 1).Value = "↑主題1"

Sheets("主題2").Select
ActiveSheet.Range("A2", ActiveSheet.Range("B2").End(xlDown)).Select
Selection.Copy
Sheets("總表").Select
....
....從這裡偵測最下列+1的部分，我有上網看文章試過很多方法但是都不大行
再麻煩各位大大幫我看看 ..
附上檔案舉例說明

book1.zip (370.46 KB)

樓主熱帖

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2018-1-5 14:22 | 只看該作者

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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 91
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-4-20

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

3^#

發表於 2018-1-5 16:42 | 只看該作者

回復 1# macro0029

Sub ex()
Dim ar(), ay()
With Sheets("總表")
r = 2
Do Until .Cells(r, 1) = ""
If .Cells(r, "J") = "收支調整" Then
If .Cells(r, "A") = "7070" Then
ReDim Preserve ar(s)
ar(s) = Array(.Cells(r, "A"), .Cells(r, "D"), .Cells(r, "E"), .Cells(r, "F"), .Cells(r, "G") & .Cells(r, "H"), .Cells(r, "I"), .Cells(r, "J"))
s = s + 1
Else
ReDim Preserve ay(i)
ay(i) = Array(.Cells(r, "A"), .Cells(r, "D"), .Cells(r, "E"), .Cells(r, "F"), .Cells(r, "G") & .Cells(r, "H"), .Cells(r, "I"), .Cells(r, "J"))
i = i + 1
End If
End If
r = r + 1
Loop
End With
Sheets("製票機構是7070且類別為收支調整").[A2].Resize(s, 7) = Application.Transpose(Application.Transpose(ar))
Sheets("製票機構非7070且類別為收支調整").[A2].Resize(i, 7) = Application.Transpose(Application.Transpose(ay))
End Sub

複製代碼

學海無涯_不恥下問

TOP