麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 執行速度過慢如何簡化 [打印本頁]

作者: lyc43210 時間: 2015-4-12 17:34 標題: 執行速度過慢如何簡化

本帖最後由 lyc43210 於 2015-4-12 17:36 編輯

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

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

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

目前我是這樣寫

Sub hm()
i% = 1
Do
c = Cells(i, 1).End(xlToRight).Column
If c < 11 Then
a = Range(Cells(i + 1, 1), Cells(i + 1, 10))
Range(Cells(i, c), Cells(i, 11)) = a
Rows(i + 1).Delete
End If
i = i + 1
Loop Until Cells(i, 1) = ""
End Sub

複製代碼

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

謝謝大家

作者: luhpro 時間: 2015-4-13 00:40

大家好我是剛學習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)
(對儲存格做動作會比單純計算數字要花更多時間)

如此,應該會有改善.

Sub hm()
Dim i%, c
i = 1
Do
c = Cells(i, 1).End(xlToRight).Column
If c < 11 Then
Range(Cells(i + 1, 1), Cells(i + 1, 10 - c)).Cut Cells(i, c + 1)
Rows(i + 1).Delete
End If
i = i + 1
Loop Until Cells(i, 1) = ""
End Sub

複製代碼

作者: lyc43210 時間: 2015-4-13 12:33

回復 2# luhpro

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

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

作者: luhpro 時間: 2015-4-13 22:00

回復 luhpro

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

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

嗯?
變的更慢了嗎?

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

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

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

Sub hm()
Dim i%, c%, s%
i = 1
s = Columns.Count
Do
c = Cells(i, s).End(xlToLeft).Column
If c < 11 Then
i = i + 1
With Cells(i, 1)
Range(.Offset(0), .Offset(, 9)).Copy .Offset(-1, c)
.EntireRow.Delete
End With
End If
Loop Until Cells(i, 1) = ""
End Sub

複製代碼

作者: Hsieh 時間: 2015-4-14 10:54

回復 1# lyc43210
試試看

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

複製代碼

作者: luhpro 時間: 2015-4-14 21:14

本帖最後由 luhpro 於 2015-4-14 21:16 編輯

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

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

處理前:
[attach]20645[/attach]

處理後:
[attach]20646[/attach]

作者: lyc43210 時間: 2015-4-15 13:30

嗯?
變的更慢了嗎?

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

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

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

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

複製代碼

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

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

作者: bobomi 時間: 2015-4-15 14:34

本帖最後由 bobomi 於 2015-4-15 14:38 編輯

不是最快的方法

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

作者: stillfish00 時間: 2015-4-15 20:06

本帖最後由 stillfish00 於 2015-4-15 20:16 編輯

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

'假設每行最少都有一筆資料
Sub Test()
Dim arSrc, arDes, m As Long, n As Long
With ActiveSheet
arSrc = .[a1].CurrentRegion.Value
If UBound(arSrc) Mod 2 = 1 Then MsgBox "資料非偶數行": Exit Sub
ReDim arDes(1 To UBound(arSrc) / 2, 1 To UBound(arSrc, 2))
n = 1: m = 1
For i = 1 To UBound(arSrc)
For j = 1 To UBound(arSrc, 2)
If arSrc(i, j) = "" Then
Exit For
Else
If n > UBound(arDes, 2) Then ReDim Preserve arDes(1 To UBound(arDes), 1 To n)
arDes(m, n) = arSrc(i, j)
n = n + 1
End If
Next
If i Mod 2 = 0 Then n = 1 : m = m + 1
Next
End With
'處理完後的資料新增工作表貼上
With Sheets.Add
.[a1].Resize(UBound(arDes), UBound(arDes, 2)).Value = arDes
End With
End Sub

複製代碼

作者: Hsieh 時間: 2015-4-16 20:55

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

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

複製代碼

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