[發問] 執行速度過慢 如何簡化

lyc43210

大家好 我是剛學習vba的新手
有問題想請教

有一個工作表
偶數列的資料要移到上面奇數列後面補齊
不過奇數列最後一格不是完全空的 有個空白
補齊後每列的長度都是相同的

Ex.
[1234 ]
[123]
[123456 ]
[1]
     ↓
[1234123]
[1234561]

目前我是這樣寫

1. Sub hm()
   
2.    
   
3.     i% = 1
   
4.    
   
5.     Do
   
6.         c = Cells(i, 1).End(xlToRight).Column
   
7.         If c < 11 Then
   
8. 
   
9.             a = Range(Cells(i + 1, 1), Cells(i + 1, 10))
   
10.             Range(Cells(i, c), Cells(i, 11)) = a
    
11.             Rows(i + 1).Delete
    
12.         End If
    
13.         
    
14.         i = i + 1
    
15.     Loop Until Cells(i, 1) = ""
    
16.    
    
17. End Sub

複製代碼

能夠達成我想要的目的
可是執行速度太慢了
工作表資料有十幾萬列
我執行10分鐘只能完成將近1/3
想請教該如何簡化 使速度加快完成

謝謝大家

Hsieh

回復 7# lyc43210
陣列速度會好些

1. Sub ex()
   
2. Dim ar()
   
3. x = 6 '指定整理後欄數
   
4. With ActiveSheet
   
5. Set Rng = .Columns("A:H").SpecialCells(xlCellTypeConstants)
   
6. k = Application.CountA(Rng)
   
7. s = Int(k / x) + IIf(k > Int(k / x) * x, 1, 0) '計算陣列列數
   
8. ReDim ar(s, 1 To x) '宣告陣列
   
9. For Each a In Rng
   
10. i = i + 1
    
11. r = Int((i - 1) / x)
    
12. j = i - r * x
    
13.    ar(r, j) = a.Value '陣列賦值
    
14. Next
    
15. .Columns("A:H") = "" '清空原資料
    
16. .[A1].Resize(r + 1, x) = ar '寫入陣列
    
17. End With
    
18. End Sub

複製代碼

stillfish00

回復 7# lyc43210
Delete/Copy 這些動作都比較慢 , 資料量大時盡量少用

1. '假設每行最少都有一筆資料
   
2. Sub Test()
   
3.     Dim arSrc, arDes, m As Long, n As Long
   
4.    
   
5.     With ActiveSheet
   
6.         arSrc = .[a1].CurrentRegion.Value
   
7.         If UBound(arSrc) Mod 2 = 1 Then MsgBox "資料非偶數行": Exit Sub
   
8.         ReDim arDes(1 To UBound(arSrc) / 2, 1 To UBound(arSrc, 2))
   
9.         
   
10.         n = 1: m = 1
    
11.         For i = 1 To UBound(arSrc)
    
12.             For j = 1 To UBound(arSrc, 2)
    
13.                 If arSrc(i, j) = "" Then
    
14.                     Exit For
    
15.                 Else
    
16.                     If n > UBound(arDes, 2) Then ReDim Preserve arDes(1 To UBound(arDes), 1 To n)
    
17.                     arDes(m, n) = arSrc(i, j)
    
18.                     n = n + 1
    
19.                 End If
    
20.             Next
    
21.             If i Mod 2 = 0 Then n = 1 : m = m + 1
    
22.         Next
    
23.     End With
    
24.    
    
25.     '處理完後的資料新增工作表貼上
    
26.     With Sheets.Add
    
27.         .[a1].Resize(UBound(arDes), UBound(arDes, 2)).Value = arDes
    
28.     End With
    
29.    
    
30. End Sub

複製代碼

bobomi

不是最快的方法

    Sub hm()
      
        Application.ScreenUpdating = 0        
        i% = 1
        Do
            c = Cells(i, 1).End(xlToRight).Column
            If c < 11 And (i Mod 2) = 1 Then
                k = k + 1
               
                a = Range(Cells(i, 1), Cells(i, c))
                Range(Cells(k, 1), Cells(k, c - 1)) = a
               
                a = Range(Cells(i + 1, 1), Cells(i + 1, 10))
                Range(Cells(k, c), Cells(k, 11)) = a
            End If
            
            i = i + 1
        Loop Until Cells(i, 1) = ""
        
        Range(Cells(i, 1), Cells(k + 1, 1)).EntireRow.Delete
    End Sub

lyc43210

嗯?
變的更慢了嗎?

我想我大概知道原因,
因為計算式變多了,
若資料筆數不多則差異不大,
你的資料量 ...
luhpro 發表於 2015-4-13 22:00

謝謝你的建議
不過速度都沒明顯提升

我也試著照你的建議 一次一項修改嘗試
發現速度有較明顯差異的寫法 反而卻是

1. a = Range(Cells(i + 1, 1), Cells(i + 1, 10))
   
2. Range(Cells(i, c), Cells(i, 11)) = a

複製代碼

這樣看起來較冗長
可是我不知道為何 卻會比cut或copy只要一行就夠了還快一些


-------
你的理解是對的 我想達成的目的就是這樣
也感謝Hsieh大
執行很快就完成了 可惜不是我要的結果

luhpro

回復  lyc43210
試試看
Hsieh 發表於 2015-4-14 10:54

這個程式的執行結果與我所理解到的樓主需求不一樣呢,
我猜樓主是要底下這樣的結果:
(樓主的處理內容也有可能是文字, 例子中全數字是為了容易產生範例資料,主要是第二列資料搬到第一列左邊,搬移後每列資料數量會是相同的.)

處理前:

下載 (14.77 KB)
處理前

2015-4-14 21:13

處理後:

下載 (11.6 KB)
處理後

2015-4-14 21:13

Hsieh

回復 1# lyc43210
試試看

1. Sub ex()
   
2. Dim Ar() As String, i&, t$, s&
   
3. For i = 1 To [A1].End(xlDown).Row Step 2
   
4.   t = Trim(Cells(i, 1)) & Cells(i + 1, 1)
   
5.    ReDim Preserve Ar(s)
   
6.    Ar(s) = t
   
7.    s = s + 1
   
8. Next
   
9. [B1].Resize(s, 1) = Application.Transpose(Ar)
   
10. End Sub

複製代碼

luhpro

回復  luhpro

謝謝你提供的建議
確實有簡化了
可是不知為何 執行的速度反而更慢了

還是說
我原先 ...
lyc43210 發表於 2015-4-13 12:33

嗯?
變的更慢了嗎?

我想我大概知道原因,
因為計算式變多了,
若資料筆數不多則差異不大,
你的資料量太大感覺就會很明顯了.

可以先試著那把 Cut 改成 Copy 試試,
Cut會比Copy多出把原資料清除的動作,
而這其實在Rows.delete就有把整列刪掉了,
所以清除的動作是可以省略的.

另外多用變數取代增減變數計算.
再則善用 with 簡化從源頭開始索引物件的指令.
還有 End(xlToRight) 與 End(XlDown) 在只有 起始儲存格有資料時可能會指到最後一行(列).
上述應該都會有效果的,試試 :

1. Sub hm()
   
2.    
   
3.     Dim i%, c%, s%
   
4.    
   
5.     i = 1
   
6.     s = Columns.Count
   
7.    
   
8.     Do
   
9.         c = Cells(i, s).End(xlToLeft).Column
   
10.         If c < 11 Then
    
11.             i = i + 1
    
12.             With Cells(i, 1)
    
13.               Range(.Offset(0), .Offset(, 9)).Copy .Offset(-1, c)
    
14.               .EntireRow.Delete
    
15.             End With
    
16.         End If
    
17.         
    
18. 
    
19.     Loop Until Cells(i, 1) = ""
    
20.    
    
21. End Sub

複製代碼

lyc43210

回復 2# luhpro

謝謝你提供的建議
確實有簡化了
可是不知為何 執行的速度反而更慢了

還是說
我原先的邏輯想法 執行速度本來就不佳
要達到同樣目的
其實有更好的寫法可以實作

luhpro

大家好 我是剛學習vba的新手
有問題想請教

有一個工作表
偶數列的資料要移到上面奇數列後面補齊
不過 ...
lyc43210 發表於 2015-4-12 17:34

把
a = Range(Cells(i + 1, 1), Cells(i + 1, 10))
Range(Cells(i, c), Cells(i, 11)) = a
改成
Range(Cells(i + 1, 1), Cells(i + 1, 10)).Cut Cells(i, c + 1)
只用 c 好像是不對的, 建議改成 C + 1.
(將搬移動作直接由一個函數完成)

再將 Range(Cells(i + 1, 1), Cells(i + 1, 10)).Cut Cells(i, c + 1)
改成
Range(Cells(i + 1, 1), Cells(i + 1, 10-c)).Cut Cells(i, c + 1)
(對儲存格做動作會比單純計算數字要花更多時間)

如此,應該會有改善.

1. Sub hm()
   
2.    
   
3.     Dim i%, c
   
4.    
   
5.     i = 1
   
6.    
   
7.     Do
   
8.         c = Cells(i, 1).End(xlToRight).Column
   
9.         If c < 11 Then
   
10. 
    
11.             Range(Cells(i + 1, 1), Cells(i + 1, 10 - c)).Cut Cells(i, c + 1)
    
12.             Rows(i + 1).Delete
    
13.         End If
    
14.         
    
15.         i = i + 1
    
16.     Loop Until Cells(i, 1) = ""
    
17.    
    
18. End Sub

複製代碼