Board logo

標題: [發問] 總表匯集試問 [打印本頁]
作者: macro0029    時間: 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的部分，我有上網看文章試過很多方法但是都不大行
    再麻煩各位大大幫我看看 ..
    附上檔案舉例說明
作者: GBKEE    時間: 2018-1-5 14:22

回復 1# macro0029
試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Sh As Worksheet, Rng As Range, xRng As Range, i As Long
  4.     Set Sh = Sheets("總表")    '**資料庫的工作表
  5.     Set xRng = Sh.Range("a1", Sh.Range("a1").End(xlToRight).End(xlDown))    '**資料庫的範圍
  6.     Set Rng = Sh.Cells(1, Columns.Count - 1).Resize(2, 2)    '**進階篩選的準則範圍
  7.     Rng.Range("B1") = Sh.Range("A1").End(xlToRight)    '**進階篩選的準則欄位 [類別]
  8.     Rng.Range("A1") = Sh.Range("A1") & "A"   '**進階篩選的準則欄位 [製票機構A]
  9.     '*PS:重要**  計算式準則時,準則的欄位不可與資料庫的欄位同****
  10.     Rng.Range("B2") = "收支調整" '**進階篩選的準則欄位 [類別] 條件
  11.     With Sheets("主題1")
  12.         .Cells.Clear
  13.         '***[製票機構]此欄資料的數字為文字格式****
  14.         Rng.Range("A2") = "=製票機構<>""7070"""    '**進階篩選的準則欄位 [製票機構A] 條件
  15.         xRng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Rng, CopyToRange:=.[a1]
  16.         '**xRng.AdvancedFilter:資料庫的進階篩選方法
  17.         '**參數 xlFilterCopy 資料庫的進階篩選動作
  18.         '**參數 CriteriaRange :準則範圍
  19.         '**參數 CopyToRange: 如果 Action 為 xlFilterCopy，此引數即為複製列的目的範圍。否則，會忽略此引數。
  20.         .Range("B:C").Delete  '(發動機構,列帳機構) 刪除
  21.         .Range("E1") = "會計科目"
  22.         i = 2
  23.         Do
  24.         .Cells(i, "E") = .Cells(i, "E") & .Cells(i, "F") '（總，細），合併至E欄（會計科目）
  25.             i = i + 1
  26.         Loop Until .Cells(i, "E") = ""
  27.         .Range("E:E").NumberFormatLocal = "@"  '設為文字格式
  28.         .Range("F:F").Delete
  29.     End With
  30.     With Sheets("主題2")
  31.         .Cells.Clear
  32.      '   Rng.Range("A2") = "=製票機構=""7070"""
  33.         xRng.AdvancedFilter xlFilterCopy, Rng, .[a1]
  34.         .Range("b:c").Delete
  35.         .Range("E1") = "會計科目"
  36.         i = 2
  37.         Do
  38.         .Cells(i, "E") = .Cells(i, "E") & .Cells(i, "F")
  39.             i = i + 1
  40.         Loop Until .Cells(i, "E") = ""
  41.         .Range("E:E").NumberFormatLocal = "@"
  42.         .Range("F:F").Delete
  43.     End With
  44.     Rng.Clear
  45. End Sub
複製代碼
作者: Hsieh    時間: 2018-1-5 16:42

回復 1# macro0029
  1. Sub ex()
  2. Dim ar(), ay()
  3. With Sheets("總表")
  4. r = 2
  5. Do Until .Cells(r, 1) = ""
  6. If .Cells(r, "J") = "收支調整" Then
  7.    If .Cells(r, "A") = "7070" Then
  8.       ReDim Preserve ar(s)
  9.       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"))
  10.       s = s + 1
  11.       Else
  12.       ReDim Preserve ay(i)
  13.       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"))
  14.       i = i + 1
  15.     End If
  16. End If
  17. r = r + 1
  18. Loop
  19. End With
  20. Sheets("製票機構是7070且類別為收支調整").[A2].Resize(s, 7) = Application.Transpose(Application.Transpose(ar))
  21. Sheets("製票機構非7070且類別為收支調整").[A2].Resize(i, 7) = Application.Transpose(Application.Transpose(ay))
  22. End Sub
複製代碼




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)