lcctno

回復 10# don4831

很感謝您的用心 但發生了錯誤訊息 如附圖
    lineBegin = Worksheets("Data").Range("K4") '起行
    lineEnd = Worksheets("Data").Range("L4") '迄行
   這2行K4 L4是我改的 那是配合我目前使用的輸入位置


   

下載 (127.25 KB)

2015-8-25 18:25

don4831

我想你現在需要的，並不只是單純的程式開發，而是如何使用有限的系統資源建置大量的資料。
這是滿高階的問題解決技巧，無法細說，只能提供實例。
將錄製的巨集瘦身，它使用的系統資源還是很高，
目前在我的環境下，產生1000筆左右之資料，使用資源及執行效能尚可，
若是要產生3200筆的資料，耗用約20分30秒之後，會出現訊息：【記憶體不足】。
用我的程式，我是以1000筆為處理單位，耗用約07分產生64000筆資料，正常結束。
提醒：xls一個工作表最多只能有65536筆資料。
請在《Data》工作表之I4及J4儲存格輸入起始列及終止列。

Sub copyForNext()
    Rem buffer = 999：每1000筆為1個處理單位
    Application.ScreenUpdating = False
    Call clearRow '清除舊資料
    buffer = 999
    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
            k = j + buffer
            Rows(j & ":" & k).Select
            Selection.PasteSpecial Paste:=xlPasteAll
            Selection.Copy
            Selection.PasteSpecial Paste:=xlPasteValues
            j = k
        Next
        Rem 取消複製模式
        Application.CutCopyMode = False
    Next
    Application.ScreenUpdating = True
End Sub

Sub clearRow()
    Worksheets(Array("析1", "析2", "析3", "析4", "析5", "析6", "析7", "析8", "析9", "析10")).Select
    Rows("3:" & Rows.Count).Select
    Selection.Clear
    '以下動作，只是清除先前的選擇，以免人工要去取消選擇。
    Range("A1").Select '目的：先前選擇區域的反影，只留選擇"A1"之儲存格
    Worksheets("析1").Select '目的：先前選擇十個工作表，只留一個選擇"析1"之工作表
End Sub

下載 (6.74 KB)

2015-8-27 14:47

lcctno

回復 12# don4831
可執行完畢 但統計結果錯誤 不知道那個地方有誤 我還在找您提供的程式碼 看問題出在那裏
謝謝您費時費力的幫助我

don4831

回復 11# lcctno
請確認輸入的值和資料型態是否為數字

don4831

回復 13# lcctno
我也正好要瞭解我的系統資源之極限，以便程式之開發，你的程式正好可以協助我進行，謝謝。

lcctno

回復 12# don4831

找到原因了
執行第3~1002列時正常
當執行第1003~2002列時 就不正常了 看到的是貼上的值與 執行第3~1002列之值相同
當執行第2003~3002列時 同樣結果 看到的是貼上的值與 執行第3~1002列之值相同
應該以下也會是同樣的結果
我知道應該是貼的值選錯目標 我想還是麻煩您除錯 我實在是不會修改這麼深的問題 謝謝您了

lcctno

回復 12# don4831

Sub copyForNext()
    Application.ScreenUpdating = True '因為要看動作是否正確
    'Call clearRow '清除舊資料 看能不能只清除當下要執行的地方 否則之前之值就被清除了 變成必須要從頭執行 那就無法結省處理時間(因為每週增加於工作頁"Data"之列數只有少數幾列)

    lineBegin = Worksheets("Data").Range("K4") '起行 我目前使用之位置
    lineEnd = Worksheets("Data").Range("L4") '迄行 我目前使用之位置
    buffer = Worksheets("Data").Range("M4")
    Rem buffer = 工作頁"Data"內M4之值 為1個處理單位  方便除錯 及配合未來每週小量增加的"Data"  可減少執行時間
   
    For i = 1 To 10
        Worksheets("析" & i).Activate
        Rows(2).Copy
        For j = lineBegin To lineEnd
            k = j + buffer - 1
            Rows(j & ":" & k).Select
            Selection.PasteSpecial Paste:=xlPasteAll
            Selection.Copy
            Selection.PasteSpecial Paste:=xlPasteValues
            j = k
        Next
        Rem 取消複製模式
        Application.CutCopyMode = False      
    Next
    Application.ScreenUpdating = True

    '歸位並結束Sub
    Sheets("Data").Select
    End Sub

lpk187

回復 17# lcctno

既然都是向下copy可不只複製、貼上
何不考慮自動填滿AutoFill

1. Sub xx()
   
2. Dim j4%
   
3. j4 = Sheets("DATA").[j4]
   
4. For i = 1 To 10
   
5.     With Sheets("析" & i)
   
6.         dl = .[a65536].End(xlUp).Row
   
7.         If j4 <> dl Then .Rows(dl & ":" & dl).AutoFill _
   
8.         Destination:=.Rows(dl & ":" & j4), Type:=xlFillDefault
   
9.     End With
   
10. Next
    
11. End Sub

複製代碼

lcctno

回復 18# lpk187
謝謝您的建議
如果使用自動填滿到終止列 那7000列甚至10000列  可能沒有幾台電腦能順利執行完成 因為太佔電腦資源 且每次都得浪費很多時間 只為了在分頁"Data"中增加數列的資料 而必須全部再運算一次 且完全沒有選擇性

don4831

回復 17# lcctno

先處理第一個問題：
'Call clearRow '清除舊資料 看能不能只清除當下要執行的地方 否則之前之值就被清除了 變成必須要從頭執行 那就無法結省處理時間(因為每週增加於工作頁"Data"之列數只有少數幾列)
請問：你所謂的當下是什麼？你上次提到要自第3行起清除資料，我只是call它，以免新舊資料不分。