[發問] 誰能幫這幾乎重複動作的VBA瘦身 謝謝

lcctno

由於在下是vba初學者 故嘗試將我使用函數寫的數百mb之excell檔 使用錄製巨集的方式 來將該檔瘦身 雖然瘦身後可正常使用 但我想應該程式碼也有簡化的可能性
我知道可以將  Rows("3:101").Select 改成 Rows("3:1001").Select 但會發生類似系統資源不夠的警告語 故只好寫成一次只判斷100筆的資料 但我目前的資料也接近6000筆了 且還會繼續增加
希望有高手能幫助我簡化它 並讓它能順利的執行到 10001筆 (為將來留後路) 謝謝了

目前瘦身的處理過程是將每一分頁 指保留一列之函數 使用vba將之複製並貼上99列函數後 在將附製上之結果變成純文字再貼回原處 依此類推...工作表.由"析1" 到"析10"  總共10分頁 如附圖

下載 (210.62 KB)

2015-8-23 18:31

分隔線++++++++++++++++++++++++++++++++++++++++++++++
'判斷列1之值是否在工作表"Data"對應之每日高低值的範圍內

Sub 判斷列()

'2~101

'製作判斷列
    Sheets("析1").Select
    Rows("2:2").Select
    Selection.Copy
    Rows("3:101").Select
    ActiveSheet.Paste
   
'瘦身
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
   
'製作判斷列
    Sheets("析2").Select
    Rows("2:2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Rows("3:101").Select
    ActiveSheet.Paste
        
'瘦身
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
   
  ...............
. ....略過很多比工程碼...............


'製作判斷列
Sheets("析10").Select
    Rows("2:2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Rows("202:301").Select
    ActiveSheet.Paste
            
'瘦身
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
Sheets("Data").Select
End Sub


匯出之巨集
判斷列.bas.zip (640 Bytes)

下載次數: 18

2015-8-23 18:48

ikboy

Sub ZZ()
Dim ar, br
ar = Array("析1", "析2", "析3", "析4", "析5", "析6", "析7", "析8", "析9", "析10")
For i = 0 To UBound(ar)
    Select Case i
    Case 0 To UBound(ar) - 1
        With Sheets(ar(i))
            .Rows(2).Copy .Rows("3:101")
            br = .Rows("3:4")
            .Rows("3:101") = br
        End With
    Case UBound(ar)
        With Sheets(ar(i))
            .Rows(2).Copy .Rows("201:301")
            br = .Rows("201:301")
            .Rows("201:301") = br
        End With
    End Select
Next
End Sub

lcctno

回復 2# ikboy

感謝您的熱心幫助 但這樣執行只能比對300筆資料 我是想要能執行到10001
還有想要請教 可否能由外部之值 例如於 "Data" 之分頁內 加入2個輸入格 可以輸入  [起始列數]="Data"之L4     [結束列數]="Data"之M4 做區段之比對 這樣執行起來會省很多時間
在此先謝謝您的費心了

ikboy

回復 3# lcctno


Sub ZZ()
Dim ar, br, MyRng
Myrng = sheets("Data" ).[L4] & “:” & sheets("Data" ).[M4]        Rem[起始列數]="Data"之L4     [結束列數]="Data"之M4      
ar = Array("析1", "析2", "析3", "析4", "析5", "析6", "析7", "析8", "析9", "析10")
For i = 0 To UBound(ar)
    Select Case i
    Case 0 To UBound(ar) - 1
        With Sheets(ar(i))
            .Rows(2).Copy .Rows(myrng)
            br = .Rows(myrng)
            .Rows(myrng) = br
        End With
    Case UBound(ar)
        With Sheets(ar(i))
            .Rows(2).Copy .Rows("201:301") Rem 此處如此類推
            br = .Rows("201:301")
            .Rows("201:301") = br
        End With
    End Select
Next
End Sub

lcctno

回復 4# ikboy

送上原檔 請您試試 不知道那裏出問題 其中
[執行]之按鈕是我錄製的 可以正常執行7000列之資料 但執行7000列要花費很久的時間
[xx]之按鈕是您第一次寫的 執行錯誤(非程式碼錯誤)
[yy]之按鈕是您第二次寫的 執行錯誤(非程式碼錯誤)

還請您多照顧了 謝謝您

   
~test% -.zip (396.17 KB)

下載次數: 17

2015-8-24 17:36

ikboy

看到了問題是代碼中的中文字源於不同語系, 在您的檔案中亂碼了, 請手動更改
ar = Array("析1", "析2", "析3", "析4", "析5", "析6", "析7", "析8", "析9", "析10")

don4831

透過工作管理員之處理程序可觀察EXCEL使用系統資源之情況。
我的環境：記憶體4G,可用2.9G，EXCEL用達299,000K時就會當。
只開【~test% -.xls】檔，不開其他檔，
(1)未執行前，EXCEL使用的系統資源：CPU使用率26%，記憶體用91,372K
(2)執行後，分析至6時，EXCEL使用的系統資源：CPU使用率61%，記憶體用209,336K
(3)分析至7時，EXCEL使用的系統資源：CPU使用率55%，記憶體用285,176K
(4)分析至8時，EXCEL使用的記憶體逾290,000K時，用ESC中斷作業。
公式相當耗資源，這支程式，幾乎所有的工作表都有公式，
如果不能強化系統資源，建議拆檔，將公式轉成程式和結果資料分開呈現。

lcctno

回復 6# ikboy

奇怪  在我這端看起來很正常 並沒有亂碼???
且都能執行

lcctno

回復 7# don4831
先感謝您的用心與建議 辛苦您了
就是因為這檔案執行起來 真的很佔資源 且又費時 已勉強使用數年了 (因為我只會用函數寫) 所以才會貼文 想改請高手幫助我 改用VBA之工程寫法

don4831

透過起行及迄行執行，可超過萬筆copy：
Sub test()
    Rem '起行=3，迄行=10000，執行時間：16:13:30~16:47:10
    Application.ScreenUpdating = False
    lineBegin = Worksheets("Data").Range("I4") '起行
    lineEnd = Worksheets("Data").Range("J4") '迄行
    For i = 1 To 10
        Worksheets("析" & i).Activate
        Rows(2).Copy
        For j = lineBegin To lineEnd
            Rows(j).PasteSpecial Paste:=xlPasteValues
        Next
        Rem 取消複製模式
        Application.CutCopyMode = False
    Next
    Application.ScreenUpdating = True
End Sub