[發問] 自動清除功能

PJChen

請幫幫忙,這個程式已進入最後階段就完成了...

來源檔有1064列
目的檔有1073列
當來源檔把有資料的範圍A:AA複製到目的檔B:AB後,自動清除目的檔1065:1073列的字(要能Delete一整列但不要刪除列,因為目的檔的AC欄之後還有公式)

注意事項：
1. 這個程式測試過沒問題,只是當目的檔資料多於來源檔時,我希望增加一項清除"多餘資料"的功能
2. 清除多餘資料的寫法,要能自動偵測,因為來源檔及目的檔的資料隨時會有變動，所以不能用Delete 第?列:第?列的寫法
3. 目的檔中的1102~1104列有計算公式，我大約都會讓它與資料保持10列以上的距離,所以請把這個也考量進去,它不能被Delete
4. 請儘可能不要修改原先的程式

下載 (134.13 KB)

2017-7-25 22:23

1. Sub 庫存更新()
   
2. '
   
3. '
   
4. '
   
5. 
   
6. '
   
7.     Dim Msg As Boolean, W As Workbook, Wb As Workbook  'W As "來源檔"      Wb As "目的檔"
   
8.    
   
9.     'Boolean 型態的預設值為 False
   
10.     '*******Workbooks 開啟的活頁簿物件集合****
    
11.     For Each W In Workbooks
    
12.         If UCase(W.Name) = UCase("庫存資料表.xlsx") Then  'UCase的功能是什麼?
    
13.             Msg = True  '檔案已開啟
    
14.             Exit For
    
15.         End If
    
16.     Next
    
17.     '*****************************************
    
18.     If Msg = True Then '檔案已開啟
    
19.         Set W = Workbooks("庫存資料表.xlsx")
    
20.     Else               '檔案尚未打開時
    
21.         Set W = Workbooks.Open("Q:\00_科毅\出貨文件連結\FromERP\庫存資料表.xlsx")
    
22.     End If
    
23. 
    
24.     '*****************************************
    
25.     If Msg = True Then '檔案已開啟
    
26.         Set Wb = Workbooks("ERP_Data.xlsx")
    
27.     Else               '檔案尚未打開時
    
28.         Set Wb = Workbooks.Open("Q:\00_科毅\出貨文件連結\ERP_Data.xlsx")
    
29.     End If
    
30. 
    
31.     '*****************************************Sorting以.Range("L1")為首
    
32. Windows("庫存資料表.xlsx").Activate
    
33.     Range("G1").Select
    
34.     Selection.AutoFilter  '建立自動篩選
    
35.     Range("G2").Select
    
36. ActiveWindow.FreezePanes = True '凍結window
    
37. 'ActiveWindow.FreezePanes = False '取消凍結window
    
38. With Workbooks("庫存資料表.xlsx")
    
39.    With .Sheets("庫存資料表")
    
40.    Set b = .Range("L1").CurrentRegion
    
41. A = Array("L", "F") '若有其他Sorting順位也可加入
    
42.     .AutoFilter.Sort.SortFields.Clear
    
43.     For i = 0 To 1   '指A = Array("L", "F") 有幾個sorting項目,2個就是0 To 1
    
44.        .AutoFilter.Sort.SortFields.Add Key:=b.Columns(A(i)) _
    
45.         , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    
46.         xlSortNormal
    
47.     Next
    
48.     With .AutoFilter.Sort
    
49.         .Header = xlYes
    
50.         .MatchCase = False
    
51.         .Orientation = xlTopToBottom
    
52.         .SortMethod = xlPinYin
    
53.         .Apply
    
54.     End With
    
55.   End With
    
56. End With
    
57. W.Save
    
58.         'Workbooks("庫存資料表.xlsx").Close True    '存檔後關閉檔案
    
59.         
    
60.     '*****************************************
    
61.     With W.Sheets("庫存資料表")
    
62.         Set A = Intersect(.UsedRange, .Range("A:AA")).SpecialCells(xlCellTypeVisible)  '只選擇有資料的範圍
    
63.      End With
    
64.         
    
65.      With Wb
    
66.         'a.Copy .Sheets("庫存").Range("B1")  '完全複製到sheet的B1
    
67.         '*************************************
    
68.         A.Copy
    
69.         .Sheets("庫存").Range("B1").PasteSpecial xlPasteValues '選擇性貼上值
    
70.         '*************************************
    
71.         Application.CutCopyMode = False      '***不處於剪下或複製模式
    
72.         '.Close True    '目的檔存檔後關閉檔案
    
73.    Wb.Save   '目的檔存檔
    
74.     End With
    
75.     W.Close False '來源檔關閉檔案(不會問是否存檔)
    
76. End Sub

複製代碼

GBKEE

回復 1# PJChen

UCase的功能是什麼?
你學習的不夠認真,不懂要看看說明

試試看

1. Option Explicit
   
2. Dim 目的檔 As Workbook, 來源檔 As Workbook
   
3. Sub 庫存更新()
   
4.     Dim xRng As Range
   
5.     File_settings 來源檔, "庫存資料表.xlsx"
   
6.     File_settings 目的檔, "ERP_Data.xlsx"
   
7.     With 來源檔.Sheets(1)
   
8.         .Cells.Sort Key1:=.Columns("L"), Key2:=.Columns("F"), Header:=xlYes
   
9.         Set xRng = .UsedRange  'UsedRange->工作表所使用的範圍,如A:AA之後再也沒資料
   
10.         xRng.Copy 'A:AA複製到目的檔B:AB
    
11.     End With
    
12.     With 目的檔.Sheets("庫存")
    
13.        .Range("B1").PasteSpecial xlPasteValues '選擇性貼上值
    
14.         '自動清除目的檔1065:1073列
    
15.         .Range("a" & xRng.Rows.Count + 1, .Range("A1101")).Resize(, 27).Clear
    
16.     End With
    
17.     來源檔.Close False
    
18.     目的檔.Save
    
19. End Sub
    
20. Sub File_settings(xFile As Workbook, 工作頁 As String) '檔案設定
    
21.     Dim xPath As String
    
22.     xPath = ThisWorkbook.Path & "\"
    
23.     If UCase(工作頁) <> UCase("ERP_Data.XLSX") Then xPath = xPath & "FromERP\"
    
24.     On Error Resume Next
    
25.     Set xFile = Workbooks(工作頁)
    
26.     If Err > 0 Then Set xFile = Workbooks.Open(xPath & 工作頁)
    
27.     If xFile.Name = "" Then
    
28.         MsgBox "請查看 " & vbLf & xPath & vbLf & "是否有 [" & 工作頁 & "]"
    
29.         End
    
30.     End If
    
31. End Sub

複製代碼

PJChen

回復 2# GBKEE

大大,

因為我原來的程式有排序功能，這個新的程式沒把來源檔的排序功能寫進去,
1. 可以幫忙把它加上去嗎？
2. 更新程式後,要把來源檔關閉.

我本來想原來的排序功能直接添上去，但因為你的寫法不同,我加上去的話它就整個不能執行了。

PJChen

回復 2# GBKEE

大大,
請指導一下,我是要來源檔在未複製資料之前先排序,但總是有些問題
1) 來源檔與目的檔同時事先開啟,或同時不要開啟,它都無法執行
2) 先開啟目的檔,再執行巨集這時它會自行打開來源檔,這樣就可以完全執行也會先排序再貼上.
3) 我要怎麼修改讓它完全正常？

1. Option Explicit
   
2. Dim 目的檔 As Workbook, 來源檔 As Workbook
   
3. Sub 庫存更新()
   
4.     Dim xRng As Range
   
5.     File_settings 來源檔, "庫存資料表.xlsx"
   
6.     File_settings 目的檔, "ERP_Data.xlsx"
   
7.     Set xRng = 來源檔.Sheets(1).UsedRange  'UsedRange->工作表所使用的範圍,如A:AA之後再也沒資料
   
8.    
   
9.     '來源檔第一個工作表,排序 1) L  2)F
   
10.      With 來源檔.Sheets(1).Range("A:AA")
    
11.     .Cells.Sort Key1:=.Columns("L"), Key2:=.Columns("F"), _
    
12. Header:=xlYes
    
13.          xRng.Copy 'A:AA複製到目的檔B:AB
    
14.     With 目的檔.Sheets("庫存")
    
15.        .Range("B1").PasteSpecial xlPasteValues '選擇性貼上值
    
16.         
    
17.         '自動清除目的檔1065:1073列
    
18.         .Range("a" & xRng.Rows.Count + 1, .Range("A1101")).Resize(, 37).Clear
    
19.         End With
    
20.     End With
    
21.     來源檔.Close False '來源檔關閉檔案(不會問是否存檔)
    
22.     目的檔.Save
    
23.    
    
24.     End Sub
    
25. Sub File_settings(xFile As Workbook, 工作頁 As String) '檔案設定
    
26.     Dim xPath As String
    
27.     xPath = ThisWorkbook.Path & "\"
    
28.     If UCase(工作頁) <> UCase("ERP_Data.XLSX") Then xPath = xPath & "FromERP\"
    
29.     On Error Resume Next
    
30.     Set xFile = Workbooks(工作頁)
    
31.     If Err > 0 Then Set xFile = Workbooks.Open(xPath & 工作頁)
    
32.     If xFile.Name = "" Then
    
33.         MsgBox "請查看 " & vbLf & xPath & vbLf & "是否有 [" & 工作頁 & "]"
    
34.         End
    
35.     End If
    
36. End Sub

複製代碼

GBKEE

回復 4# PJChen

1) 來源檔與目的檔同時事先開啟,或同時不要開啟,它都無法執行??
2) 先開啟目的檔,再執行巨集這時它會自行打開來源檔,這樣就可以完全執行也會先排序再貼上.    ??

Sub 庫存更新(), 這程序你不是要放在VBA報表指令.XLSM
程式碼 有指定  來源檔與目的檔, 可以不管事先開啟,或沒開啟的問題

1. File_settings 來源檔, "庫存資料表.xlsx"
   
2.     File_settings 目的檔, "ERP_Data.xlsx"
   
3. '**********來源檔是同VBA報表指令的資料夾\FromERP\*********
   
4. If UCase(工作頁) <> UCase("ERP_Data.XLSX") Then xPath = xPath & "FromERP\"

複製代碼

2#程式碼已更新 再試試看
你4#的程式碼執沒錯ㄚ

PJChen

回復 5# GBKEE

大大,

我又試了好幾遍,還是跟之前說的一樣,必須先開啟ERP_Data.xlsx,執行才會正常..
我PO上讓您執行看看.
Try_20170729.rar (709.34 KB)

下載次數: 1

2017-7-29 15:49

GBKEE

回復 6# PJChen
抱歉了,2個地方少加 " ."
再試試看

With 來源檔.Sheets(1)
        .Cells.Sort Key1:= .Columns("L"), Key2:= .Columns("F"), Header:=xlYes

PJChen

回復 7# GBKEE

真太神奇了,..大大
現在正常了，為什麼少了"."差這麼多？...謝謝你了,真是太苦惱人了.

GBKEE

回復 8# PJChen
With 來源檔.Sheets(1)    '這物件是工作表
        .Cells.Sort Key1:=Columns("L"), Key2:=.Columns("F"), Header:=xlYes
        '** 沒有一點的   Columns("L"), 是指作用中工作表的Columns("L")
         '** 如恰巧作用中工作表是,來源檔.Sheets(1),,不會有錯誤發生的
       '**這是小地方很容易疏忽的
        Set xRng = .UsedRange    'UsedRange->工作表所使用的範圍,如A:AA之後再也沒資料
        xRng.Copy 'A:AA複製到目的檔B:AB
    End With

PJChen

回復 9# GBKEE

感謝大大說明...