Board logo

標題: [分享] 優化巨大的VBA [打印本頁]
作者: play9091    時間: 2011-7-20 21:25     標題: 優化巨大的VBA

本帖最後由 play9091 於 2011-7-21 09:43 編輯

小弟寫了一個VBA來解決，每天要做三小時報告的囧境……花了二天的時間把它弄完了，但是它非常的巨大，而小弟功力尚淺，找不到優化的手斷，想請益一下版上的先進們幫助一下！！！
  1. Sub name_test()
  2.     Application.ScreenUpdating = False
  3.     Application.DisplayAlerts = False
  4.     T = Time
  5.     For I = 4 To 10
  6. '叫出KPI報告
  7.     KPI = InputBox("C#KPI報告路俓(順序從C4∼C9，最後才是C1)")
  8.     Workbooks.Open (KPI)
  9.     Set KPI = Nothing
  10.     KPI = ActiveWorkbook.Name
  11. '叫出每日C#報告
  12.     Clu = InputBox("C#報告路俓(順序從C4∼C9，最後才是C1)")
  13.     Workbooks.Open (Clu)
  14.     Set Clu = Nothing
  15.     Clu = ActiveWorkbook.Name
  16. '複制每日C#報告的sheet到KPI報告
  17.     If I <> 10 Then
  18.     Workbooks(Clu).Sheets("sheet1").Copy After:=Workbooks(KPI).Sheets("M2000 BSC KPI Report (2)")
  19.     Sheets("sheet1").Name = "C" & I
  20.     ElseIf I = 10 Then
  21.     Workbooks(Clu).Sheets("sheet1").Copy After:=Workbooks(KPI).Sheets("sheet5")
  22.     Sheets("Sheet1 (2)").Name = "C" & I
  23.     End If
  24.     Workbooks(Clu).Close SaveChanges:=False
  25.     Set Clu = Nothing
  26. '叫出paging報告
  27.     Pag = InputBox("paging報告路俓")
  28.     Workbooks.Open (Pag)
  29.     Set Pag = Nothing
  30.     Pag = ActiveWorkbook.Name
  31. '複制paging報告的sheet到KPI報告
  32.     If I <> 10 Then
  33.     Workbooks(Pag).Sheets("sheet1").Copy After:=Workbooks(KPI).Sheets("M2000 BSC KPI Report (2)")
  34.     Sheets("sheet1").Name = "paging"
  35.     ElseIf I = 10 Then
  36.     Workbooks(Pag).Sheets("sheet1").Copy After:=Workbooks(KPI).Sheets("sheet2")
  37.     Sheets("Sheet1 (2)").Name = "paging"
  38.     End If
  39.     Workbooks(Pag).Close SaveChanges:=False
  40.     Set Pag = Nothing
  41. '開始出報告
  42.     Sheets("paging").Select
  43.     Range("A11").Select
  44.     Range(Selection, Selection.End(xlToRight)).Select
  45.     Range(Selection, Selection.End(xlDown)).Select
  46.     Selection.Copy
  47.     If I <> 10 Then
  48.     Sheets("M2000 MSC Paging").Select
  49.     ElseIf I = 10 Then
  50.     Sheets("sheet5").Select
  51.     End If
  52.     Range("A2").Select
  53.     Range(Selection, Selection.End(xlToRight)).Select
  54.     Range(Selection, Selection.End(xlDown)).Select
  55.     ActiveSheet.Paste
  56. '清除剪貼薄
  57. '    My.Computer.Clipboard.Clear() = True
  58.     Sheets("C" & I).Select
  59.     Range("A11").Select
  60.     Range(Selection, Selection.End(xlToRight)).Select
  61.     Range(Selection, Selection.End(xlDown)).Select
  62.     Application.CutCopyMode = False
  63.     Selection.Copy
  64.     If I <> 10 Then
  65.     Sheets("M2000 BSC KPI Report").Select
  66.     Range("A3").Select
  67.     ElseIf I = 10 Then
  68.     Sheets("sheet2").Select
  69.     Range("A2").Select
  70.     End If
  71.     Range(Selection, Selection.End(xlToRight)).Select
  72.     Range(Selection, Selection.End(xlDown)).Select
  73.     ActiveSheet.Paste
  74.     If I <> 10 Then
  75. '清除剪貼薄
  76. '    My.Computer.Clipboard.Clear() = True
  77.     Sheets("C" & I).Select
  78.     Application.CutCopyMode = False
  79.     Sheets("C" & I).Range("E3").Value = "=IF(ISLOGICAL(E4)," & "" & ",A10)"
  80.     Sheets("C" & I).Range("F3").Value = "=IF(ISLOGICAL(F4)," & "" & ",A10)"
  81.     Sheets("C" & I).Range("E4").Value = "=Text(Right(A11, 8), ""hh:mm:ss"") >= ""02:00:00"""
  82.     Sheets("C" & I).Range("F4").Value = "=Text(Right(A11, 8), ""hh:mm:ss"") <= ""21:30:00"""
  83.     Range("A11").Select
  84.     Range(Selection, Selection.End(xlToRight)).Select
  85.     Range(Selection, Selection.End(xlDown)).Select
  86.     Range("A10:EQ5482").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
  87.         Range("E3:F4"), Unique:=False
  88.     Selection.Copy
  89.     Sheets("M2000 BSC KPI Report (2)").Select
  90.     Range("A3").Select
  91.     Range(Selection, Selection.End(xlToRight)).Select
  92.     Range(Selection, Selection.End(xlDown)).Select
  93.     ActiveSheet.Paste
  94.     End If
  95.     Sheets("C" & I).Delete
  96.     Sheets("paging").Delete
  97.     D = InputBox("輸入今天的日期(EX：16)")
  98.     If I <> 10 Then
  99.     Sheets("sheet2").Select
  100.     ElseIf I = 10 Then
  101.     Sheets("BSC23-43 BTS Track").Select
  102.     End If
  103.     Cells.Replace What:=D - 1, Replacement:=D, LookAt:=xlPart, SearchOrder _
  104.         :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
  105.     Workbooks(KPI).Close SaveChanges:=True
  106.     Set KPI = Nothing
  107.     Next I
  108.     MsgBox ("共用時: " & Format(Time - T, "HH:MM:SS"))
  109. End Sub
複製代碼
作者: GBKEE    時間: 2011-7-21 08:21

本帖最後由 GBKEE 於 2011-7-21 08:31 編輯

回復 1# play9091
  1. KPI = InputBox("C#KPI報告路俓(順序從C4∼C9，最後才是C1)")
  2.     Workbooks.Open (KPI)
  3.     Set KPI = Nothing
  4.     KPI = ActiveWorkbook.Name
複製代碼
KPI = InputBox("C#KPI報告路俓(順序從C4∼C9，最後才是C1)")
    Set KPI = Workbooks.Open(KPI)
  1.     Workbooks(Clu).Sheets("sheet1").Copy After:=Workbooks(KPI).Sheets("M2000 BSC KPI Report (2)")
複製代碼
Clu.Sheets("sheet1").Copy After:=KP.Sheets("M2000 BSC KPI Report (2)")
  1. '開始出報告
  2. Sheets("paging").Select
  3.     Range("A11").Select
  4.     Range(Selection, Selection.End(xlToRight)).Select
  5.     Range(Selection, Selection.End(xlDown)).Select
  6.     Selection.Copy
  7.     If I <> 10 Then
  8.     Sheets("M2000 MSC Paging").Select
  9.     ElseIf I = 10 Then
  10.     Sheets("sheet5").Select
  11.     End If
  12.     Range("A2").Select
  13.     Range(Selection, Selection.End(xlToRight)).Select
  14.     Range(Selection, Selection.End(xlDown)).Select
  15.     ActiveSheet.Paste
複製代碼
'開始出報告
    If I <> 10 Then
    Sheets("M2000 MSC Paging").Select
    ElseIf I = 10 Then
    Sheets("sheet5").Select
    End If
Sheets("paging").Range("A11").CurrentRegion.Copy  ActiveSheet.Range("A2")
CurrentRegion  :將選擇範圍自動延伸->     Range(Selection, Selection.End(xlToRight)).Select
                                                                                Range(Selection, Selection.End(xlDown)).Select
其餘類似可自行修改
作者: play9091    時間: 2011-7-21 09:39

本帖最後由 play9091 於 2011-7-21 09:53 編輯

我把它修改成下面的樣子，不要用「inputbox」直接在sheet裡面把路俓先寫好，這樣子就不用等「inputbox」跳出來。
但是它確出現了「超出索引範圍」代號9的錯誤，我只要把BOOK的物件拿掉就正常了，但我必須要指定BOOK比較不會出錯。我試了好多方法，它就是不給動作，不知道是不是我漏了什麼地方，煩請先進指導一下！！！
  1. Sub name_test()
  2.     Application.ScreenUpdating = False
  3.     Application.DisplayAlerts = False
  4.     T = Time
  5.     For I = 4 To 10
  6. '叫出KPI報告
  7.     KPI = Workbooks("路俓版").Sheets("工作表3").Range("D" & I).Value  '←這裡出錯！！！
  8.     Workbooks.Open (KPI)
  9.     Set KPI = Nothing
  10.     KPI = ActiveWorkbook.Name
複製代碼
另外，板主回複的簡化方式
  1. Set KPI = Workbooks.Open(KPI)
複製代碼
這取出來的是全部關於BOOK的內容，我只須要BOOK的檔名而已！！！應該是用不上！而且我下面必須要用到BOOK的名字，精確一點應該會比較好！
作者: GBKEE    時間: 2011-7-21 10:16

本帖最後由 GBKEE 於 2011-7-21 11:33 編輯

回復 3# play9091
Workbooks("路俓版").Sheets("工作表3").Range("D" & I).Value  '←這裡出錯！！！
試看看   Workbooks("路俓版.XLS")   這檔案必需是已開啟的.
我只須要BOOK的檔名而已！！！應該是用不上！而且我下面必須要用到BOOK的名字，精確一點應該會比較好！
我將你的程式碼簡化是配合你的程序需求
1樓的程式碼有
Workbooks(Clu).Close SaveChanges:=False     '這不是之前 將檔案開啟 後作關閉的動作嗎?
Workbooks(Pag).Close SaveChanges:=False
作者: play9091    時間: 2011-7-21 11:08

試看看   Workbooks("路俓版.XLS")   這檔案不需是已開啟的.\
YES！！！真的搞定了，版大真強，這招先學起來……用這個方法是不是連沒有開的檔案都可以抓到資料？？

我將你的程式碼簡化是配合你的程序需求
1樓的程式碼有
Workbooks(Clu).Close SaveChanges:=False     '這不是之前 將檔案開啟 後作關閉的動作嗎?

它的確是關閉之前開啟的檔案沒有錯，但是Workbooks(Clu)裡面的「Clu」必須是精確的檔名，要不然會關不掉……

另外：我想要只複製一個「範圍」的「值」，我還想不到怎麼做，因為一次要複製的資料太多了(百萬級的)！複製的時候要等很久……有沒有可以「只複製值」的方法！
我想了一些，但都沒有成功……請先進們指導一下如何只取值！！！
  1.     Sheets("C" I).Select
  2.     Range("A11").Select
  3.     Range(Selection, Selection.End(xlToRight)).Select
  4.     Range(Selection, Selection.End(xlDown)).Select
  5.     set GGG.value = selection.value   '出錯
複製代碼
作者: GBKEE    時間: 2011-7-21 11:29

本帖最後由 GBKEE 於 2011-7-21 11:34 編輯

回復 5# play9091
沒有開的檔案都可以抓到資料  不可以的上一回覆有筆誤  以更正 ,可用匯入外部資料讀取.

Set KPI = Workbooks.Open(KPI) , 將變數KPI指定為  Workbooks.Open(KPI) 這物件.
KPI.Close     這樣就關掉

應該是這樣   
Set GGG = Selection       將變數 GGG指定為 Range物件, Selection是Range物件.
作者: play9091    時間: 2011-7-21 12:52

本帖最後由 play9091 於 2011-7-21 13:29 編輯

沒有開的檔案都可以抓到資料  不可以的上一回覆有筆誤  以更正 ,可用匯入外部資料讀取.
OK，清楚了……

Set KPI = Workbooks.Open(KPI) , 將變數KPI指定為  Workbooks.Open(KPI) 這物件.
KPI.Close     這樣就關掉
嗯∼又學到一招了，但是用這個方法的話，我上面已經指定字串給Clu了，沒有清除又指定新的資料給他，這樣子不會造成記憶體堆疊嗎？會吃比較多記憶體……而且我發現
Set KPI = Workbooks.Open(KPI)
比
set KPI = nothing
KPI = ActiveWorkbook.Name
還要慢……

應該是這樣   
Set GGG = Selection       將變數 GGG指定為 Range物件, Selection是Range物件.
所以說應該把它寫成下面這個樣子才取得出來囉！
Set GGG = Selection
Set BBB.Value =  GGG.Value
才可以「只取出值」囉！等一下試試……
剛剛試了……我失敗了……

另外：進階篩選有時候會出錯，這要怎麼樣子去除錯呢？？
有一大筆資料，我要篩選出0200<=X<=2130
所以我寫了這個判別式：
=AND(TEXT(RIGHT(A11, 8), "hh:mm:ss") >= "02:00:00",TEXT(RIGHT(A11, 8), "hh:mm:ss") <= "21:30:00")
它有時候會成功，有時候會失敗這應該怎麼做呢？？
作者: GBKEE    時間: 2011-7-21 15:02

本帖最後由 GBKEE 於 2011-7-21 15:08 編輯

回復 7# play9091
這是工作表函數寫法  =AND(TEXT(RIGHT(A11, 8), "hh:mm:ss") >= "02:00:00",TEXT(RIGHT(A11, 8), "hh:mm:ss") <= "21:30:00")
你的寫法有誤 你不是有問過
  1. Sub Ex()
  2.     If TimeValue(Right(Range("A11"), 8)) >= #2:00:00 AM# And TimeValue(Right(Range("A11"), 8)) <= #9:30:00 PM# Then
  3.         MsgBox "篩選時間內"
  4.     End If
  5. '''''''' 一樣的效果   '''''''''''''
  6.     If TimeValue(Right([A11], 8)) >= TimeValue("2:00:00") And TimeValue(Right([A11], 8)) <= TimeValue("9:30:00") Then
  7.         MsgBox "篩選時間內"
  8.     End If
  9. End Sub
複製代碼
作者: play9091    時間: 2011-7-21 15:10

本帖最後由 play9091 於 2011-7-21 15:15 編輯
回復  play9091
這是工作表函數寫法  =AND(TEXT(RIGHT(A11, 8), "hh:mm:ss") >= "02:00:00",TEXT(RIGHT(A ...
GBKEE 發表於 2011-7-21 15:02


看版主的寫法是只有對A11做判別而已……但是……我要篩選的範圍有上萬個儲存格……用LOOP的話會跑很久吧！
這也是我選用進階篩選的原因……

我上面說的不知道對不對，或許是我理解不夠……是不是可以舉一個實例可以篩選的。下面是我寫的篩選內容……
  1.     Sheets("C" & I).Range("E3").Value = "=IF(ISLOGICAL(E4)," & "" & ",A10)"
  2.     Sheets("C" & I).Range("E4").Value = "=AND(TEXT(RIGHT(A11, 8), ""hh:mm:ss"") >= ""02:00:00"",TEXT(RIGHT(A11, 8), ""hh:mm:ss"") <= ""21:30:00"")"
  3.     Range("A11").Select
  4.     Range(Selection, Selection.End(xlToRight)).Select
  5.     Range(Selection, Selection.End(xlDown)).Select
  6.     Range("A10:EQ5482").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
  7.         Range("E3:E4"), Unique:=False
複製代碼
作者: GBKEE    時間: 2011-7-21 15:45

回復 9# play9091
上傳 檔案說明看看
作者: play9091    時間: 2011-7-21 16:14

付檔為我的範例檔……
在E3和E4輸入公式，用「進階篩選」……詳見VBE
作者: GBKEE    時間: 2011-7-21 17:02

本帖最後由 GBKEE 於 2011-7-21 17:04 編輯

回復 11# play9091
沒問題, 這樣進階篩選對阿.
工作表函數 ISLOGICAL 參照的值是邏輯值 傳回 TRUE    ,E4 傳回 為TRUE 或FALSE 同樣是邏輯值,
=IF(ISLOGICAL(E4)," & "" & ",A10)"    永遠傳回 ""     這公式是誤打誤撞的
  1. Sub ttt()
  2.     Sheets("Sheet1").Range("E3") = ""   
  3.    '或 Sheets("Sheet1").Range("E3") = "ABC"
  4.   ' 進階篩選 :    篩選準則 是計算是準則(條件裡有計算公式)  , 準則欄位: 不可是資料庫內的欄位 (可以是空白欄位)
  5.     '計算是準則    如E4=  A10   是篩選不到資料
  6.     Sheets("Sheet1").Range("E4").Value = "=AND(TEXT(RIGHT(A11, 8), ""hh:mm:ss"") >= ""02:00:00"",TEXT(RIGHT(A11, 8), ""hh:mm:ss"") <= ""21:30:00"")"
  7.     Range("A10").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
  8.         Range("E3:E4"), Unique:=False
  9. End Sub
複製代碼
作者: play9091    時間: 2011-7-21 17:42

回復 12# GBKEE

上傳錯範例了……那個範例檔是可以成功篩選的……
上傳另外一個檔，同樣的情況，做同樣的篩選，但是確篩選不出來……我的問題是這個…版主應該會清楚我的問題
作者: GBKEE    時間: 2011-7-21 19:29

回復 13# play9091
可以呀,程式碼跟上一檔案差不多,找不到錯誤.
  1. Sub ttt()
  2.     Sheets("Sheet1").Range("E3").Value = ""
  3.     Sheets("Sheet1").Range("E4").Value = "=AND(TEXT(RIGHT(A11, 8), ""hh:mm:ss"") >= ""02:00:00"",TEXT(RIGHT(A11, 8), ""hh:mm:ss"") <= ""21:30:00"")"
  4.    ' Range("A11").Select
  5.    ' Range(Selection, Selection.End(xlToRight)).Select
  6.    ' Range(Selection, Selection.End(xlDown)).Select
  7.     Range("A10:EQ5482").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
  8.         Range("E3:E4"), Unique:=False
  9. End Sub
複製代碼
作者: play9091    時間: 2011-7-21 22:32

回復 14# GBKEE

感謝版大耐心的回答我的每一個爛問題……關於進階篩選的問題，我找到錯誤的地方了，就是我選擇被篩選的地方選的不夠大……所以有些的資料沒有被篩選到。
明天我又要開始我的另外一份VBA旅程，還請先進們多多指教……
我也會持續的打擾各位的！！！



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