[發問] 簡化巨集程式

PJChen

最近一直在修改巨集程式,因為懂得不多,所以諸多問題,請見諒.
麻辣家族各位熱心人士幫忙我寫了些程式,我自己稍加修改成所需要的巨集程式,以下這個雖然改了好幾個小時,可以用了,但我知道有很多重複的語言,使得巨集跑得很慢,我已經試著修改N次了,都行不通,不知有沒有人可以幫我精簡它?
Sub copy_from_Multi_format()
'
' copy_from_Multi_format 巨集

   With Workbooks("2011 BCMart Multi-Format.xlsx").Sheets("BCM控管")
    .Columns("A:CZ").Hidden = False
    Set A = Intersect(.UsedRange, .Range("A:CZ")).SpecialCells(xlCellTypeVisible)
    With Workbooks("VBA Cluster.xlsm")  '請改成要複製活頁簿的名稱(已經打開)
    With Sheets("BCM控管")
    .Columns("A:CZ").Hidden = False
    A.Copy Workbooks("VBA Cluster.xlsm").Sheets("BCM控管").Range("A1")  '完全複製
   
   End With
   End With
   End With
   
       With Workbooks("VBA Cluster.xlsm")  '請改成要複製活頁簿的名稱(已經打開)
    With Sheets("BCM控管")
    Set A = Intersect(.UsedRange, .Range("A:CZ")).SpecialCells(xlCellTypeVisible)
    A.Copy
    .Range("A1").PasteSpecial xlPasteValues '選擇性貼上值
   End With
   End With
   
    Workbooks("VBA Cluster.xlsm").Activate
    Sheets("BCM控管").Select
    Columns("F:F").Select
    Selection.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    Workbooks("VBA Cluster.xlsm").Activate
    Sheets("VBA").Select
    Range("B1").Select
End Sub

GBKEE

回復 1# PJChen

1. Option Explicit
   
2. Sub Acopy_from_Multi_format()
   
3.     Dim Sh(1 To 2) As Worksheet
   
4.     '*** 工作表 指定給變數: 如程序很大 修改工作表名稱時不必在程序中一一更改 ***   
   
5.     Set Sh(1) = Workbooks("2011 BCMart Multi-Format.xlsx").Sheets("BCM控管")
   
6.     Set Sh(2) = Workbooks("VBA Cluster.xlsm").Sheets("BCM控管")
   
7.        With Sh(1)
   
8.         .Columns("A:CZ").Hidden = False
   
9.         Set A = Intersect(.UsedRange, .Range("A:CZ")).SpecialCells(xlCellTypeVisible)
   
10.         Sh(2).Columns("A:CZ").Hidden = False
    
11.         A.Copy Sh(2).Range("A1")  '完全複製
    
12.     End With
    
13.     With Sh(2)  '請改成要複製活頁簿的名稱(已經打開)
    
14.         .Columns("A:CZ").Hidden = False
    
15.         Set A = Intersect(.UsedRange, .Range("A:CZ")).SpecialCells(xlCellTypeVisible)
    
16.         A.Copy .Range("A1")  '完全複製
    
17.         .Columns("F:F").Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
    
18.         SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    
19.         ReplaceFormat:=False
    
20.     End With
    
21.     Workbooks("VBA Cluster.xlsm").Sheets("VBA").Activate
    
22.     Range("B1").Select
    
23. End Sub

複製代碼

PJChen

GBKEE,上述程式執行很快,但有二個問題,因為這跟我錄製巨集的程式碼不同,我不會改,請幫我修正以下:

1. 全部的程式在同一工作表會用同樣方法從三個Sheets複製資料,即:
Workbooks("2011 BCMart Multi-Format.xlsx").Sheets("BCM控管") copy 到 Workbooks("VBA Cluster.xlsm").Sheets("BCM控管")
Workbooks("2011 BCMart Multi-Format.xlsx").Sheets("Factory Ship") copy 到 Workbooks("VBA Cluster.xlsm").Sheets("Factory Ship")
Workbooks("2011 BCMart Multi-Format.xlsx").Sheets("Chart") copy 到 Workbooks("VBA Cluster.xlsm").Sheets("Chart")

2. 因為工作表"2011 BCMart Multi-Format.xlsx"都有公式,希望貼上另一個工作表 Workbooks("VBA Cluster.xlsm")後除了完全複製格式外,還要改成"貼上值"不要公式.

這種情形下我改什麼修改程式碼?

GBKEE

回復 3# PJChen

1. Option Explicit
   
2. Sub Acopy_from_Multi_format()
   
3.     Dim Wb(1 To 2) As Workbook, Sh As Worksheet    '或是 Sh As Variant
   
4.     '*** 指定給變數: 如程序很大 修改名稱時不必在程序中一一更改 ***
   
5.     Set Wb(1) = Workbooks("2011 BCMart Multi-Format.xlsx")
   
6.     Set Wb(2) = Workbooks("VBA Cluster.xlsm")
   
7.     For Each Sh In Wb(1).Sheets(Array("BCM控管", "Factory Ship", "Chart"))   '
   
8.         'For Each Sh In Array("BCM控管", "Factory Ship", "Chart")   'Sh As Variant 如此作
   
9.         With Sh
   
10.             'With Wb(1).Sheets(Sh)                                  'Sh As Variant 如此作
    
11.             .Columns("A:CZ").Hidden = False
    
12.              Intersect(.UsedRange, .Range("A:CZ")).SpecialCells(xlCellTypeVisible).Copy
    
13.                                                                     '先做複製的動作
    
14.             With Wb(2).Sheets(Sh.Name)
    
15.              '   With Wb(2).Sheets(Sh)                              'Sh As Variant 如此作
    
16.                 .Range("A1").PasteSpecial Paste:=xlPasteAll          '完全複製
    
17.                 .Range("A1").PasteSpecial Paste:=xlPasteValues       '複製值
    
18.                 .Columns("A:CZ").Hidden = False
    
19.             End With
    
20.         End With
    
21.     Next
    
22.     Application.CutCopyMode = False
    
23.     'CutCopyMode 屬性: 設定 [剪下] 或 [複製] 模式的狀態。可為 True、False 或一個 XLCutCopyMode 常數，如下列表格所示。讀/寫 Long。
    
24. End Sub

複製代碼

PJChen

GBKEE大大,
三個不同的SHEET,是採用同樣方法去複製及完全貼上及貼上值,但每個sheet的欄位都不同,所以無法以一致性方去作,請問我要怎麼改?感謝你!
Workbooks("2011 BCMart Multi-Format.xlsx").Sheets("BCM控管") A:CZ
Workbooks("2011 BCMart Multi-Format.xlsx").Sheets("Factory Ship") A:AI
Workbooks("2011 BCMart Multi-Format.xlsx").Sheets("Chart") A:AP

GBKEE

回復 5# PJChen

1. Option Explicit
   
2. Sub Acopy_from_Multi_format()
   
3.     Dim Wb(1 To 2) As Workbook, xS As Integer, Ar1(), Ar2()
   
4.     '*** 指定給變數: 如程序很大 修改名稱時不必在程序中一一更改 ***
   
5.     Dim Ar(1 To 2)
   
6.     Set Wb(1) = Workbooks("2011 BCMart Multi-Format.xlsx")
   
7.     Set Wb(2) = Workbooks("VBA Cluster.xlsm")
   
8.     Ar1 = Array("BCM控管", "Factory xsip", "Chart")    '置入陣列
   
9.     Ar2 = Array("A:CZ", "A:AI", "A:AP")                '置入陣列
   
10.     For xS = 0 To UBound(Ar1)     '-> Array("BCM控管", "Factory xsip", "Chart")
    
11.         With Wb(1).Sheets(Ar1(xS))                                  '代入 Ar1(xS)
    
12.             .Columns("A:CZ").Hidden = False
    
13.             Intersect(.UsedRange, .Range(Ar2(xS))).SpecialCells(xlCellTypeVisible).Copy
    
14.                                    ''代入 Ar2(xS) : 先做複製的動作
    
15.                 With Wb(2).Sheets(Ar1(xS))                              '代入 Ar1(xS)
    
16.                     .Range("A1").PasteSpecial Paste:=xlPasteAll         '完全複製
    
17.                     .Range("A1").PasteSpecial Paste:=xlPasteValues      '複製值
    
18.                     .Columns("A:CZ").Hidden = False
    
19.             End With
    
20.         End With
    
21.     Next
    
22.     Application.CutCopyMode = False
    
23.     'CutCopyMode 屬性: 設定 [剪下] 或 [複製] 模式的狀態。可為 True、False 或一個 XLCutCopyMode 常數，如下列表格所示。讀/寫 Long。
    
24. End Sub

複製代碼

PJChen

下載 (224.12 KB)

2012-1-21 14:12

GBKEE,謝謝你,一切運作正常.
想請教:我將程式COPY到工作表的時候,"Option Explicit"為什麼都會跑到線的上方?

GBKEE

回復 7# PJChen
你將複製程式碼後,貼在已有的程式碼下方當然會在那裡出現.
刪掉  或移 到頂端  就好了.

PJChen

也可以刪除的嗎?謝謝.

GBKEE

回復 9# PJChen
如有 這些Option  都必須置於 模組的頂端
Option Explicit     陳述式 : 在模組層次中強迫每個在模組裏的變數都必須明確的宣告。
Option Compare 陳述式 : 在模組層次中用來宣告當比較字串資料時，所預設使用的比較方法。
Option Base         陳述式 : 在模組層次中用來宣告陣列索引的預設下限。
Option Private     陳述式 : 當主應用程式允許可引用跨越多個專案時，Option Private Module 可以避免模組被外部專案所引用。但若主應用程式不允許跨專案引用時，則 Option Private 沒有作用。