Board logo

標題: [發問] 簡化巨集程式 [打印本頁]
作者: PJChen    時間: 2012-1-21 03:17     標題: 簡化巨集程式

最近一直在修改巨集程式,因為懂得不多,所以諸多問題,請見諒.
麻辣家族各位熱心人士幫忙我寫了些程式,我自己稍加修改成所需要的巨集程式,以下這個雖然改了好幾個小時,可以用了,但我知道有很多重複的語言,使得巨集跑得很慢,我已經試著修改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    時間: 2012-1-21 08:10

回復 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    時間: 2012-1-21 10:14

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    時間: 2012-1-21 11:47

本帖最後由 GBKEE 於 2012-1-21 11:49 編輯

回復 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    時間: 2012-1-21 12:07

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    時間: 2012-1-21 13:51

本帖最後由 GBKEE 於 2012-1-21 13:56 編輯

回復 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    時間: 2012-1-21 14:13

[attach]9297[/attach]GBKEE,謝謝你,一切運作正常.
想請教:我將程式COPY到工作表的時候,"Option Explicit"為什麼都會跑到線的上方?
作者: GBKEE    時間: 2012-1-21 15:53

回復 7# PJChen
你將複製程式碼後,貼在已有的程式碼下方當然會在那裡出現.
刪掉  或移 到頂端  就好了.
作者: PJChen    時間: 2012-1-21 19:12

也可以刪除的嗎?謝謝.
作者: GBKEE    時間: 2012-1-21 19:47

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

謝謝你的說明.
作者: homeman    時間: 2012-1-26 18:15

請教先進, Set A = Intersect(.UsedRange, .Range("A:CZ")).SpecialCells(xlCellTypeVisible) 這段主要是
設定要複製的複製的範圍嗎 ? 有點無法理解設定這一段
作者: GBKEE    時間: 2012-1-27 08:34

回復 12# homeman
Intersect 方法 傳回 Range 物件，此物件代表兩個或多個範圍重疊的矩形範圍。
  1. Sub Ex()
  2.     With ActiveSheet
  3.     Set isect = Application.Intersect(.Range("A1:E5"), .Range("B1:B100"))
  4.         If isect Is Nothing Then
  5.             MsgBox "沒有 交集的範圍 "
  6.         Else
  7.          MsgBox isect.Address
  8.         isect.Select     '交集的範圍
  9.     End If
  10.     End With
  11. End Sub
複製代碼
作者: xmi    時間: 2012-1-27 10:39

我看不明 (真沒用), 但多謝GBKEE的教導.  我要多看幾次學習學習一下. 穴
作者: homeman    時間: 2012-1-27 21:07

GBKEE 先進, 謝謝您又用最簡單的例子教學, 我又學到了, Thanks
作者: jeng    時間: 2012-1-27 23:56

看看前輩間的對話，深佑自己功有待加強
有空會常來此練功
謝謝啦



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