1234567
返回列表 上一主題 發帖

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

lcctno

帖子
142 
主題
18 
精華
0 
積分
160 
點名
296  
作業系統
win10 64位元 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
臺灣 高雄市 
註冊時間
2015-7-18 
最後登錄
2024-11-6 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2015-8-23 18:49 | 只看該作者

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

本帖最後由 lcctno 於 2015-8-23 18:52 編輯

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

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






分隔線++++++++++++++++++++++++++++++++++++++++++++++
'判斷列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)
收藏 分享

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
16  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2024-10-26 

2016猴年全勤獎章
2#
發表於 2015-8-24 07:18 | 只看該作者
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

TOP

lcctno

帖子
142 
主題
18 
精華
0 
積分
160 
點名
296  
作業系統
win10 64位元 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
臺灣 高雄市 
註冊時間
2015-7-18 
最後登錄
2024-11-6 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章
3#
發表於 2015-8-24 08:19 | 只看該作者
回復 2# ikboy

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

TOP

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
16  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2024-10-26 

2016猴年全勤獎章
4#
發表於 2015-8-24 08:49 | 只看該作者
回復 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

TOP

lcctno

帖子
142 
主題
18 
精華
0 
積分
160 
點名
296  
作業系統
win10 64位元 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
臺灣 高雄市 
註冊時間
2015-7-18 
最後登錄
2024-11-6 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章
5#
發表於 2015-8-24 17:46 | 只看該作者
回復 4# ikboy

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

還請您多照顧了 謝謝您

   
~test% -.zip (396.17 KB)

TOP

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
16  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2024-10-26 

2016猴年全勤獎章
6#
發表於 2015-8-25 08:59 | 只看該作者
看到了問題是代碼中的中文字源於不同語系, 在您的檔案中亂碼了, 請手動更改
ar = Array("析1", "析2", "析3", "析4", "析5", "析6", "析7", "析8", "析9", "析10")

TOP

don4831

帖子
10 
主題
2 
精華
0 
積分
60 
點名
0  
作業系統
win7 
軟體版本
Office 2013 
閱讀權限
20 
性別
女 
來自
新北市 
註冊時間
2015-6-3 
最後登錄
2017-1-13 
7#
發表於 2015-8-25 10:28 | 只看該作者
透過工作管理員之處理程序可觀察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中斷作業。
公式相當耗資源，這支程式，幾乎所有的工作表都有公式，
如果不能強化系統資源，建議拆檔，將公式轉成程式和結果資料分開呈現。
[color=blue]KY[/color]

TOP

lcctno

帖子
142 
主題
18 
精華
0 
積分
160 
點名
296  
作業系統
win10 64位元 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
臺灣 高雄市 
註冊時間
2015-7-18 
最後登錄
2024-11-6 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章
8#
發表於 2015-8-25 10:44 | 只看該作者
回復 6# ikboy

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

TOP

lcctno

帖子
142 
主題
18 
精華
0 
積分
160 
點名
296  
作業系統
win10 64位元 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
臺灣 高雄市 
註冊時間
2015-7-18 
最後登錄
2024-11-6 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章
9#
發表於 2015-8-25 10:50 | 只看該作者
本帖最後由 lcctno 於 2015-8-25 10:51 編輯

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

TOP

don4831

帖子
10 
主題
2 
精華
0 
積分
60 
點名
0  
作業系統
win7 
軟體版本
Office 2013 
閱讀權限
20 
性別
女 
來自
新北市 
註冊時間
2015-6-3 
最後登錄
2017-1-13 
10#
發表於 2015-8-25 17:06 | 只看該作者
透過起行及迄行執行，可超過萬筆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
[color=blue]KY[/color]

TOP

        靜思自在 : 世上有兩件事不能等：一、孝順 二、行善。
1234567
返回列表 上一主題