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

標題: 可否請各位先進幫我簡化代碼 [打印本頁]

作者: fyo00241 時間: 2011-12-27 22:28 標題: 可否請各位先進幫我簡化代碼

可以請各位先進幫小弟簡化代碼,讓他執行快一點,到後面50幾行就很慢了,謝謝各位...

Private Sub jump123()
For a = 2 To 10000
  If Cells(a, 1) = "" Then Exit For
s = Cells(a, 4)

If s Like "201106*" Then
      Cells(a, 5) = "A"
End If
If s Like "201101*" Then
      Cells(a, 5) = "B"
End If
If s Like "201111*" Then
      Cells(a, 5) = "C"
End If
If s Like "201102*" Then
      Cells(a, 5) = "D"
End If
If s Like "201127*" Then
      Cells(a, 5) = "E"
End If
If s Like "1101*" Then
      Cells(a, 5) = "F"
End If
If s Like "1102*" Then
      Cells(a, 5) = "G"
End If
If s Like "1103*" Then
      Cells(a, 5) = "H"
End If
If s Like "1104*" Then
      Cells(a, 5) = "I"
End If
If s Like "1105*" Then
      Cells(a, 5) = "J"
End If
If s Like "1106*" Then
      Cells(a, 5) = "K"
End If
If s Like "1107*" Then
      Cells(a, 5) = "L"
End If
If s Like "1108*" Then
      Cells(a, 5) = "M"
End If
If s Like "1109*" Then
      Cells(a, 5) = "N"
End If
If s Like "1110*" Then
      Cells(a, 5) = "O"
End If
If s Like "1111*" Then
      Cells(a, 5) = "P"
End If
If s Like "1112*" Then
      Cells(a, 5) = "Q"
End If
If s Like "1113*" Then
      Cells(a, 5) = "R"
End If
If s Like "1114*" Then
      Cells(a, 5) = "S"
End If
If s Like "1115*" Then
      Cells(a, 5) = "T"
End If
If s Like "1116*" Then
      Cells(a, 5) = "U"
End If
If s Like "1117*" Then
      Cells(a, 5) = "V"
End If
If s Like "1118*" Then
      Cells(a, 5) = "X"
End If
If s Like "1119*" Then
      Cells(a, 5) = "Y"
End If
If s Like "1120*" Then
      Cells(a, 5) = "Z"
End If

Next a

End Sub

作者: register313 時間: 2011-12-28 14:07

本帖最後由 register313 於 2011-12-28 14:09 編輯

回復 1# fyo00241
初學者VBA
使用FIND更好但試不出來

Private Sub EE()
Application.ScreenUpdating = False
Columns("E").Clear
For a = 2 To 10000
For b = 2 To 26
If Cells(a, 1) = "" Then Exit For
If Cells(a, 4) Like Cells(b, 7) & "*" Then
Cells(a, 5) = Cells(b, 8)
End If
Next b
Next a
Application.ScreenUpdating = True
End Sub

複製代碼

[attach]8938[/attach]

作者: kimbal 時間: 2011-12-28 14:09

試試這樣(我沒有測試)
但是如果要寫10000 個cell,不會快很多.

Private Sub jump123()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For a = 2 To 10000
If Cells(a, 1) = "" Then Exit For
s = Left(Cells(a, 4), 6)
b = False
If s = "201106" Then
b = True
Cells(a, 5) = "A"
ElseIf s = "201101" Then
b = True
Cells(a, 5) = "B"
ElseIf s = "201111" Then
b = True
Cells(a, 5) = "C"
ElseIf s = "201102" Then
b = True
Cells(a, 5) = "D"
ElseIf s = "201127" Then
b = True
Cells(a, 5) = "E"
End If
If Not (b) Then
k1 = Left(s, 2)
If k1 = "11" Then
k2 = Mid(s, 3, 2)
If k2 >= "01" And k2 <= "17" Then
Cells(a, 5) = Chr(69 + Val(k2))
ElseIf k2 >= "18" And k2 <= "20" Then
Cells(a, 5) = Chr(70 + Val(k2))
End If
End If
End If
Next a
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

複製代碼

作者: fyo00241 時間: 2011-12-29 01:12

本帖最後由 fyo00241 於 2011-12-29 01:13 編輯

感謝2位大大的分享,我再貼上我後來的代碼,請2位幫我簡化一下,因為速度到後面就很慢了我key條碼它判斷時就會lag了,先感謝2位了!!
arr = [d2:d10000]
For i = 1 To UBound(arr)
s = arr(i, 1)
If s Like "201106*" Then
      brr(i) = "手打鐘Ⅰ"

ElseIf s Like "201101*" Then
      brr(i) = "手打鐘"

ElseIf s Like "201111*" Then
      brr(i) = "手打鐘Ⅱ"

ElseIf s Like "201102*" Then
      brr(i) = "手打鐘"

ElseIf s Like "201103*" Then
      brr(i) = "手打鐘"

ElseIf s Like "201127*" Then
      brr(i) = "T27印表機"

ElseIf s Like "1101*" Then
      brr(i) = "中文鴿鐘"

ElseIf s Like "1102*" Then
      brr(i) = "英文鴿鐘"

ElseIf s Like "1103*" Then
      brr(i) = "中文語音鴿鐘"

ElseIf s Like "1104*" Then
      brr(i) = "英文語音鴿鐘"

ElseIf s Like "1105*" Then
      brr(i) = "中文語音鴿鐘(G)"

ElseIf s Like "1106*" Then
      brr(i) = "英文語音鴿鐘(G)"

ElseIf s Like "1107*" Then
      brr(i) = "凹槽"

ElseIf s Like "1108*" Then
      brr(i) = "CI"

ElseIf s Like "1109*" Then
      brr(i) = "單格15PIN"

ElseIf s Like "1110*" Then
   brr(i) = "單格9PIN"

ElseIf s Like "1111*" Then
      brr(i) = "四合一15PIN-E"

ElseIf s Like "1112*" Then
      brr(i) = "四合一15PIN-EL"

ElseIf s Like "1113*" Then
      brr(i) = "四合一9PIN"

ElseIf s Like "1114*" Then
      brr(i) = "GPS(方形)"

ElseIf s Like "1115*" Then
      brr(i) = "525電匠"

ElseIf s Like "1116*" Then
      brr(i) = "747電匠"

ElseIf s Like "1117*" Then
      brr(i) = "T+1感應板"

ElseIf s Like "1118*" Then
      brr(i) = "傳訊機5V"

ElseIf s Like "1119*" Then
      brr(i) = "傳訊機非5V"

ElseIf s Like "1120*" Then
      brr(i) = "UID讀碼機"
End If


Next
[E2].Resize(999, 1) = Application.WorksheetFunction.Transpose(brr)

作者: register313 時間: 2011-12-29 08:23

本帖最後由 register313 於 2011-12-29 08:29 編輯

回復 4# fyo00241
1. key條碼 key在何處? 作何判斷?
2.程式功能為何?
3.很慢是大約幾秒? 依實際需求大約要幾秒完成?
4.何不附上檔案?

作者: fyo00241 時間: 2011-12-29 08:52

本帖最後由 fyo00241 於 2011-12-29 08:56 編輯

[attach]8949[/attach]
回復 5# register313
麻請了是UserForm1這個地方,也請大大幫我看一下那些地方可以再簡化,順一點的謝謝了!!

作者: register313 時間: 2011-12-29 12:59

回復 6# fyo00241
依我看你是用表單一次輸入1個序號(D欄),然後查出1個品名(E欄) ===> 需1t時間
而不是一次已有10000個序號(D欄),),然後一次查出10000個品名(E欄) ===> 需10000t時間(當然會慢)

依之前程式之寫法
  輸入第1個序號(查詢1個)  ===> 需1t時間
  輸入第2個序號(查詢2個)  ===> 需2t時間
  輸入第1000個序號(查詢1000個)  ===> 需1000t時間
  所以累積愈多序號到時候執行速度就愈慢

  先看看附檔範例是不是你要的
  在D欄輸入序號,馬上查出品名
  只會查有D欄變動之序號,而不是每次都全部重查

Private Sub worksheet_change(ByVal target As Range)
If target.Column = 4 Then
a = target.Row
For b = 2 To 27
If Cells(a, 4) Like Cells(b, 7) & "*" Then
Cells(a, 5) = Cells(b, 8)
End If
Next b
End If
End Sub

複製代碼

[attach]8954[/attach]

作者: GBKEE 時間: 2011-12-29 15:40

回復 6# fyo00241
你附檔的VBA 上鎖看不見

作者: register313 時間: 2011-12-29 18:52

回復 6# fyo00241

請問原來的程式是否能正常執行好多地方有問題

只修正本帖所提之執行速度
試試看

[attach]8955[/attach]

作者: fyo00241 時間: 2011-12-29 21:41

本帖最後由 fyo00241 於 2011-12-29 21:43 編輯

回復 8# GBKEE

報告G大:3543

作者: fyo00241 時間: 2011-12-29 21:42

本帖最後由 fyo00241 於 2011-12-30 00:36 編輯

回復 fyo00241

請問原來的程式是否能正常執行好多地方有問題

只修正本帖所提之執行速度
試試看
...
register313 發表於 2011-12-29 18:52

大大我無法下載附件......
[email protected]也無法發短消息@_@

作者: fyo00241 時間: 2011-12-30 20:23

大大我無法下載附件......
也無法發短消息@_@
fyo00241 發表於 2011-12-29 21:42

感謝大大,目前我會測試一下,文件我收到了,謝謝喔!!

作者: GBKEE 時間: 2012-1-1 09:31

本帖最後由 GBKEE 於 2012-1-1 09:39 編輯

回復 10# fyo00241
簡化 UserForm1

Private Sub ComboBox2_Change()
If ComboBox2 <> "" Then Sheets(ComboBox2.Text).Select '將工作表移到 ComboBox2
End Sub
Private Sub cmdOK_Click()
Dim Msg As String, t, s, 序號, 品名
'序號 ,品名也可key好置於工作表用於搜尋對照
序號 = Array(201106, 201101, 201111, 201102, 201103, 201127, 1101, 1102, 1103, 1104, 1105, 1106, 1107, 1108, 1109, 1110, 1111, 1112, 1113, 1114, 1115, 1116, 1117, 1118, 1119, 1120)
品名 = Array("手打鐘Ⅰ", "手打鐘", "手打鐘Ⅱ", "手打鐘", "手打鐘", _
"T27印表機", "中文鴿鐘", "英文鴿鐘", "中文語音鴿鐘", "英文語音鴿鐘", "中文語音鴿鐘(G)", _
"英文語音鴿鐘(G)", "凹槽", "CI", "單格15PIN", "單格9PIN", "四合一15PIN-E", "四合一15PIN-EL", _
"四合一9PIN", "GPS(方形)", "525電匠", "747電匠", "T+1感應板", "傳訊機5V", "傳訊機非5V", "UID讀碼機")
'*** 防呆
If ComboBox2 = "" Then Msg = "地區單位未選擇 !!!"
If in1 = False And out1 = False Then Msg = IIf(Msg = "", "出貨情況未選擇 !!!", Msg & Chr(10) & "出貨情況未選擇 !!!")
t = Application.Match(Val(Mid(TextBox1, 1, 6)), 序號, 0) '先找6位
If IsError(t) Then t = Application.Match(Val(Mid(TextBox1, 1, 4)), 序號, 0) '後找4位
If Not IsError(t) Then s = 品名(t - 1)
If IsError(t) Then Msg = IIf(Msg = "", "序號錯誤: 找不到品名 ???", Msg & Chr(10) & "序號錯誤: 找不到品名 ???")
If Msg <> "" Then
MsgBox Msg
Exit Sub
End If
'*** 防呆結束
With Cells(Rows.Count, "A").End(xlUp).Offset(1) '工作表(ComboBox2)
.Offset(0, 0) = abcName.Value
.Offset(0, 1) = ComboBox2.Value
.Offset(0, 2).Value = IIf(in1 = True, "收回", "發出")
.Offset(0, 3) = TextBox1.Value
.Offset(0, 4) = s
End With
End Sub

複製代碼

各單位工作表的Worksheet_Change 可刪除置於ThisWorkbook 中

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim rng As Range, i As Long, r
If Sh.Index > 3 Then ' Index 各單位工作表於活頁簿的排序位置
r = isTrue(Target.Value, getRangeString)
If r(0) Then MsgBox "" & r(1) & "表中已經有了！"
With Target
If .Column = 1 Or .Column = 3 Or .Column = 4 Then
If Cells(.Row, 1) <> "" And Cells(.Row, 3) <> "" And Cells(.Row, 4) <> "" Then
For i = 2 To Cells(Rows.Count, .Column).End(xlUp).Row
If Cells(i, 1) = Cells(.Row, 1) And Cells(i, 3) = Cells(.Row, 3) And Cells(i, 4) = Cells(.Row, 4) And i <> .Row Then
If rng Is Nothing Then
Set rng = Union(Cells(i, 1), Cells(i, 3), Cells(i, 4))
Else
Set rng = Union(rng, Cells(i, 1), Cells(i, 3), Cells(i, 4))
End If
End If
Next
If Not rng Is Nothing Then
Set rng = Union(rng, Cells(i, 1), Cells(.Row, 3), Cells(.Row, 4))
rng.Select
MsgBox Cells(.Row, 1) & " " & Cells(.Row, 3) & " " & Cells(.Row, 4) & " 有重複檢查一下!!"
End If
End If
End If
End With
End If
End Sub

複製代碼

作者: fyo00241 時間: 2012-1-2 23:09

回復 fyo00241
簡化 UserForm1各單位工作表的Worksheet_Change 可刪除置於ThisWorkbook 中
GBKEE 發表於 2012-1-1 09:31

感謝大大幫忙,又學了很多,我來試看看,,希望可以再幫我看一下那裡要改的...先謝謝了!!

作者: register313 時間: 2012-1-2 23:39

回復 14# fyo00241

是不是先把之前修改過的作個測試
說明一下功能有沒有問題(那邊有問題) 操作速度正不正常

作者: GBKEE 時間: 2012-1-3 08:22

本帖最後由 GBKEE 於 2012-1-3 08:24 編輯

回復 15# register313
說明一下功能有沒有問題(那邊有問題) 操作速度正不正常
樓主檔案較大,所以執行程式速度會慢一些.不瘦身是不會快的.
建議樓主將所有資料置於一個資料庫(如:日記帳)

作者: register313 時間: 2012-1-3 08:28

回復 16# GBKEE

自己改的不知如何

[attach]9002[/attach]

作者: GBKEE 時間: 2012-1-3 09:20

回復 17# register313
依原檔案             陣列比對約1.05秒 ,  工作表比對  約1.09秒
刪除剩15資料表陣列比對約0.22秒 ,  工作表比對  約0.25秒
刪除剩 1 資料表陣列比對約0.093秒 ,  工作表比對  約0.12秒

作者: fyo00241 時間: 2012-1-3 17:14

回復 fyo00241

是不是先把之前修改過的作個測試
說明一下功能有沒有問題(那邊有問題) 操作速度正不正 ...
register313 發表於 2012-1-2 23:39

大大你之前改的我測了一下可以的速度可以接受了!!

作者: fyo00241 時間: 2012-1-3 17:15

回復 register313
說明一下功能有沒有問題(那邊有問題) 操作速度正不正常
樓主檔案較大,所以執行程式速 ...
GBKEE 發表於 2012-1-3 08:22

大大你說的資料庫部份是如何做較好呢??

作者: fyo00241 時間: 2012-1-3 17:19

回復 GBKEE

自己改的不知如何
register313 發表於 2012-1-3 08:28

大大再麻煩你寄給我,謝謝了!

作者: fyo00241 時間: 2012-1-3 17:45

回復 fyo00241
簡化 UserForm1各單位工作表的Worksheet_Change 可刪除置於ThisWorkbook 中
GBKEE 發表於 2012-1-1 09:31

大大這段錯誤:無物件With Cells(Rows.Count, "A").End(xlUp).Offset(1) '工作表(ComboBox2)

作者: fyo00241 時間: 2012-1-3 18:04

大大再麻煩你寄給我,謝謝了!
fyo00241 發表於 2012-1-3 17:19

大大已收到了,測了一下速度也可以,但滑鼠執行時的圖示會久一點,不知是否正常..

作者: lcc_seven 時間: 2012-1-3 18:20

本帖最後由 lcc_seven 於 2012-1-3 18:24 編輯

有沒有試過用Excel內建函數【VLOOKUP】，應該也蠻快的喔!

也可以把Excel內建函數寫在VBA裡，這樣程式只有短短幾行，不過語法我忘記了

缺點是工作表要有一個位置放對應表

晚上我再翻一下書把相關語法PO上來

作者: fyo00241 時間: 2012-1-3 20:41

有沒有試過用Excel內建函數【VLOOKUP】，應該也蠻快的喔!

也可以把Excel內建函數寫在VBA裡，這樣程式只有 ...
lcc_seven 發表於 2012-1-3 18:20

感謝大大,煩請你提供一下我在實作看看..謝謝!!

作者: GBKEE 時間: 2012-1-3 20:50

回復 20# fyo00241
建議樓主將所有資料置於一個資料庫(如:日記帳)

回復 22# fyo00241
2007 不行阿
請加上 With Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Offset(1)

作者: lcc_seven 時間: 2012-1-3 23:28

回復 25# fyo00241

我先將你提供的資料建立在G1:H25【cells(1,7),cells(25,8)】

再用PasteData()貼10000筆資料

因為我覺得比對的過程蠻像 Select Case ，所以Sub取名為LikeSelectCase()

你參考看看，一下子就完成了

Sub PasteData()

j = 1

For i = 1 To 10000
Cells(i, 1) = Cells(j, 7)
j = j + 1
If j = 26 Then j = 1
Next i

End Sub

Sub LikeSelectCase()

For i = 1 To 10000

Cells(i, 2) = Application.WorksheetFunction.VLookup(Cells(i, 1), Range(Cells(1, 7), Cells(25, 8)), 2, False)

Next i

End Sub

[attach]9039[/attach]

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