[發問] 資料範圍複製到不同檔案&依日期分別複製

takeshilin88

請問各位大大：
懇求幫忙~~~
我有兩個檔案：
A檔：負責做支票套印
B檔：支票本存檔&支票狀況
我在A檔工作表「支票套印」完成後，可以在A檔按下一個按鈕巨集後，可以執行以下動作：
1.先查詢B檔中「支票本」工作表裡有本月到期的支票(EX:現在是106年12月，就將106年12月的資料複製到「本月到期」工作表、次月到期的支票資料(107年1月)，複製到「次月到期」工作表。
2.再到A檔中，「支票套印」工作表內新的支票資料複製到B檔的「支票本」最後資料的下一筆，EX:支票號碼A0004接A0005
3.將B檔「本月到期」工作表資料，複製到「目前支票狀況」工作表，A1位置
4.將B檔「次月到期」工作表資料，複製到「目前支票狀況」工作表，接著本月到期的資料下方貼上
請參考附檔，謝謝

支票.rar (15.72 KB)

下載次數: 12

2017-12-8 17:41

GBKEE

回復 1# takeshilin88
試試看

1. Option Explicit
   
2. Dim WB As Workbook, AR(), D As Object
   
3. Sub Main()
   
4.     Ex_yymm
   
5.     Ex_Copy
   
6. End Sub
   
7. Private Sub Ex_yymm()
   
8.     Dim i As Integer, YM As String
   
9.     Set D = CreateObject("SCRIPTING.DICTIONARY") '字典物件
   
10.     With Workbooks("A.XLSM").Sheets("支票套印")
    
11.         i = 6
    
12.         Do
    
13.             YM = Format(.Cells(i, "D"), "ee/mm")
    
14.             D(YM) = "=AND(YEAR(到期日)=" & Format(.Cells(i, "D"), "YYYY") & ",MONTH(到期日)=" & Format(.Cells(i, "D"), "mm") & ")" 'Format(.Cells(i, "D"), "ee/mm")  'YM : 字典物件的key值 (讀取月份)
    
15.             i = i + 1
    
16.         Loop Until .Cells(i, "D") = ""
    
17.         i = Application.SheetsInNewWorkbook
    
18.         Application.SheetsInNewWorkbook = D.Count + 1
    
19.         Set WB = Workbooks.Add
    
20.         Application.SheetsInNewWorkbook = 1
    
21.         .Copy WB.Sheets(1)
    
22.         WB.Sheets(1).Rows("1:4").Delete
    
23.         WB.Sheets(1).Name = .Name
    
24.     End With
    
25.     AR = D.keys
    
26. End Sub
    
27. Private Sub Ex_Copy()
    
28.     Dim Sh As Worksheet, Rng As Range, i As Integer, xRow As Integer
    
29.     Set Sh = WB.Sheets(1)
    
30.     Set Rng = Sh.Cells(1, Columns.Count).Resize(2)
    
31.     Rng.Cells(1) = "AAA"
    
32.     For i = 0 To UBound(AR)
    
33.         Rng.Cells(2) = D(AR(i))
    
34.         Sh.Range("A:D").AdvancedFilter xlFilterCopy, Rng, WB.Sheets(i + 2).[A2]
    
35.         'AdvancedFilter    進階篩選    , 篩選:複製 ,篩選準則,   複製到的地方
    
36.         With WB.Sheets(i + 2)
    
37.             .Name = Replace(AR(i), "/", "_") & " 到期"
    
38.             .[A1] = AR(i) & " 到期:"
    
39.             .[d1] = Application.Evaluate("sum(" & .[c:c].Address(, , , 1, 1) & ")")
    
40.             .[d1].NumberFormatLocal = "#,##0_ "
    
41.             xRow = WB.Sheets(WB.Sheets.Count).Cells(Rows.Count, "a").End(xlUp).Row
    
42.             If xRow > 1 Then xRow = xRow + 1
    
43.             .Range("a1").CurrentRegion.Copy WB.Sheets(WB.Sheets.Count).Cells(xRow, "A")
    
44.         End With
    
45.     Next
    
46.     Rng.Clear
    
47.     With WB
    
48.         .Sheets(WB.Sheets.Count).Name = "目前支票狀況"
    
49.         .SaveAs "D:\B.XLSX"    '存檔
    
50.     End With
    
51. End Sub

複製代碼

takeshilin88

回復 2# GBKEE

GBKEE大大：
測試過後可以使用了，但是有兩項需要小小修改的地方：
1.每個月到期的加總金額儲存格 ( 每個工作表的 D1 ) ，想要有千分位樣式，例：1,234,567
2.如果在「到期日」D欄插入一欄「說明欄」：即「說明欄」成為D欄，「到期日」成為E欄，
    我將程式碼的D都改為E，會出現陣列索引超出範圍...
請幫幫忙教我如何調整程式碼，
謝謝

takeshilin88

更正：

GBKEE大大：
測試過後可以使用了，但是有兩項需要小小修改的地方：
1.每個月到期的加總金額儲存格 ( 每個工作表的 D1 ) ，想要有千分位樣式，例：1,234,567
2.如果在「到期日」D欄插入一欄「說明欄」：即「說明欄」成為D欄，「到期日」成為E欄，
    我將程式碼的D都改為E，會出現陣列索引超出範圍.......
   第2項已經解決了
請幫幫忙教我如何調整程式碼，
謝謝

takeshilin88

回復 4# takeshilin88

幫忙設定：
    每個工作表的加總金額儲存格 ( 每個工作表的 D1 ) ，想要有千分位樣式，例：1,234,567

請參考附檔，謝謝

GBKEE

回復 5# takeshilin88

每個工作表的 D1 ) ，想要有千分位樣式，例：1,234,567
你可用錄製巨集得到的程式碼套上
自行試試看

1. .[d1] = Application.Evaluate("sum(" & .[c:c].Address(, , , 1, 1) & ")")
   
2.             .[d1] =????

複製代碼

takeshilin88

回復 6# GBKEE

GBKEE大大：
    我在
    .[d1] = Application.Evaluate("sum(" & .[c:c].Address(, , , 1, 1) & ")")
    的下一行設定
    .[d1] = Selection.NumberFormatLocal = "#,##0_ "   
    結果每個工作表的d1儲存格都變成FALSE了，
    請問是哪裡出了問題呢？

GBKEE

回復 7# takeshilin88
Selection 你可查看vba的說明看看

1. .[d1] .NumberFormatLocal = "#,##0_ "   

複製代碼

takeshilin88

回復 8# GBKEE


    謝謝GBKEE大大，
    已經可以使用了，謝謝~~
    萬分感激......

takeshilin88

求救~~
如果「到期日」的儲存格格式改成為中華民國曆，
則產生的B檔會抓不到到期日加總的資料，
好像是下面這個程式碼需要修改：
YM = Mid(.Cells(i, "D"), 1, InStrRev(.Cells(i, "D"), "/") - 1)
請各位大大幫幫忙~~

附檔
1061220-改日期格式.rar (27.22 KB)

下載次數: 8

2017-12-20 17:00