返回列表 上一主題 發帖

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

lyc43210

帖子
15 
主題
5 
精華
0 
積分
34 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2013 
閱讀權限
10 
性別
男 
註冊時間
2015-4-9 
最後登錄
2018-7-15 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2015-4-12 17:34 | 只看該作者

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

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

大家好 我是剛學習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

  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
想請教該如何簡化 使速度加快完成

謝謝大家
收藏 分享

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
15  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-12 
2#
發表於 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)
(對儲存格做動作會比單純計算數字要花更多時間)

如此,應該會有改善.
  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

  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
複製代碼

TOP

lyc43210

帖子
15 
主題
5 
精華
0 
積分
34 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2013 
閱讀權限
10 
性別
男 
註冊時間
2015-4-9 
最後登錄
2018-7-15 
3#
發表於 2015-4-13 12:33 | 只看該作者
回復 2# luhpro

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

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

TOP

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
15  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-12 
4#
發表於 2015-4-13 22:00 | 只看該作者
回復  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.         

  19.     Loop Until Cells(i, 1) = ""
  20.    
  21. End Sub
複製代碼

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
247  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-14 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
5#
發表於 2015-4-14 10:54 | 只看該作者
回復 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
複製代碼
學海無涯_不恥下問

TOP

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
15  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-12 
6#
發表於 2015-4-14 21:14 | 只看該作者
本帖最後由 luhpro 於 2015-4-14 21:16 編輯
回復  lyc43210
試試看
Hsieh 發表於 2015-4-14 10:54

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

處理前:


處理後:

TOP

lyc43210

帖子
15 
主題
5 
精華
0 
積分
34 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2013 
閱讀權限
10 
性別
男 
註冊時間
2015-4-9 
最後登錄
2018-7-15 
7#
發表於 2015-4-15 13:30 | 只看該作者
嗯?
變的更慢了嗎?

我想我大概知道原因,
因為計算式變多了,
若資料筆數不多則差異不大,
你的資料量 ...
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大
執行很快就完成了 可惜不是我要的結果

TOP

bobomi

帖子
181 
主題
5 
精華
0 
積分
197 
點名
0  
作業系統
XP 
軟體版本
2000 
閱讀權限
20 
性別
女 
註冊時間
2014-3-9 
最後登錄
2024-4-29 
8#
發表於 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

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
9#
發表於 2015-4-15 20:06 | 只看該作者
本帖最後由 stillfish00 於 2015-4-15 20:16 編輯

回復 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
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
247  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-14 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
10#
發表於 2015-4-16 20:55 | 只看該作者
回復 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
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 人生不一定球球是好球，但是有歷練的強打者，隨時都可以揮棒。
返回列表 上一主題