Code takes a long time to run

L

lixiaoming980

New Member
Joined
Jun 18, 2023
Messages
7
Office Version
  1. 365
Platform
  1. Windows
VBA Code: 
Sub delivery()
If ActiveSheet.FilterMode = True Then
    ActiveSheet.ShowAllData
End If
If Range("e3") = "" Then Exit Sub
If Range("e4") = "" Then Exit Sub
If Range("e5") = "" Then Exit Sub
If Range("e6") = "" Then Exit Sub
If Range("e7") = "" Then Exit Sub
If Range("e8") = "" Then Exit Sub
If Range("e11") = "" Then
    MsgBox "Please input supplier or contacter name"
    Exit Sub
End If
If Range("e2") = "New Item" Then
    rownum = Range("a1048576").End(xlUp).Row + 1
    Range("a" & rownum) = rownum - 13
Else
    rownum = Range("a14:a1048576").Find([e2]).Row
End If
Range("b" & rownum) = Range("e3")
Range("h" & rownum) = Range("e4")
Range("c" & rownum).Value = UCase(Range("e5"))
Range("d" & rownum) = Range("e6")
Range("e" & rownum) = Range("e7")
Range("f" & rownum) = Range("e8")
Range("g" & rownum) = Abs(Range("e10"))
Range("m" & rownum) = UCase(Range("e11"))
Range("J" & rownum) = "=I" & rownum & "*g" & rownum
ActiveWorkbook.RefreshAll
Call clear
If Range("S" & rownum) >= 2 Then
    MsgBox "Probably that you made it twice or more, check it please. "
End If
If Range("H" & rownum) = "OUT" Then
    Range("I" & rownum) = "=VLOOKUP(D" & rownum & ",Inventory!A:H,7,0)"
End If
End Sub

VBA Code: 
Sub delete()

If IsNumeric([e2]) Then
    Beep
    If MsgBox("Are you sure to erase it?", vbYesNo) = vbNo Then Exit Sub
    rownum = Range("a12:a1048576").Find([e2]).Row
    Rows(rownum).delete
    Range("e2") = "New Item"
    [e3:e11] = ""
End If
If rownum = "" Then Exit Sub
rowmax = Range("a1048576").End(xlUp).Row
x = rownum - 13
If x = 1 Then
    Range("a14").Value = ""
    Exit Sub
End If
If rowmax >= rownum Then

    For i = rownum To rowmax
        Range("a" & i).Value = x
        
        x = x + 1
    Next
End If
ActiveWorkbook.RefreshAll
End Sub
微信图片_20230618163632.png

HI, everyone, Iam a newbie of vba.. I need to speed up this code above, everytime when I run the macro "delivery()" and "delete", it has to take a ten seconds to finish that.. can somebody help me out , thanks in advance.
 

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December
Sort by date Sort by votes
VBA Code: 
Sub clear()
[e6:e10] = ""
End Sub

this is clear macro, and column(I) is a unitprice which i want vlookup it from another worksheet. column(S) I user countif to judge if I have done this row once before when four conditions are met at the same time
 
Upvote 0
I made a test , it took 12 secs to finish last two "if - endif" parts, can somebody tell me why and how to improve this?
 
Upvote 0
Hi @lixiaoming980 , Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.

Add these lines in each macro:

Application.ScreenUpdating = False​
​
and​
​
Application.ScreenUpdating = True​
​
(highlighted in blue)​

Try:

Rich (BB code): 
Sub delete()
  If IsNumeric([e2]) Then
    Beep
    If MsgBox("Are you sure to erase it?", vbYesNo) = vbNo Then Exit Sub
    rownum = Range("a12:a1048576").Find([e2]).Row
    Rows(rownum).delete
    Range("e2") = "New Item"
    [e3:e11] = ""
  End If
  If rownum = "" Then Exit Sub
  rowmax = Range("a1048576").End(xlUp).Row
  x = rownum - 13
  If x = 1 Then
    Range("a14").Value = ""
    Exit Sub
  End If
 
  Application.ScreenUpdating = False
 
  If rowmax >= rownum Then
 
    For i = rownum To rowmax
        Range("a" & i).Value = x
      
        x = x + 1
    Next
  End If
  ActiveWorkbook.RefreshAll
 
  Application.ScreenUpdating = True
 
End Sub

Sub delivery()
  If ActiveSheet.FilterMode = True Then
      ActiveSheet.ShowAllData
  End If
  If Range("e3") = "" Then Exit Sub
  If Range("e4") = "" Then Exit Sub
  If Range("e5") = "" Then Exit Sub
  If Range("e6") = "" Then Exit Sub
  If Range("e7") = "" Then Exit Sub
  If Range("e8") = "" Then Exit Sub
  If Range("e11") = "" Then
      MsgBox "Please input supplier or contacter name"
      Exit Sub
  End If
 
  Application.ScreenUpdating = False
 
  If Range("e2") = "New Item" Then
      rownum = Range("a1048576").End(xlUp).Row + 1
      Range("a" & rownum) = rownum - 13
  Else
      rownum = Range("a14:a1048576").Find([e2]).Row
  End If
  Range("b" & rownum) = Range("e3")
  Range("h" & rownum) = Range("e4")
  Range("c" & rownum).Value = UCase(Range("e5"))
  Range("d" & rownum) = Range("e6")
  Range("e" & rownum) = Range("e7")
  Range("f" & rownum) = Range("e8")
  Range("g" & rownum) = Abs(Range("e10"))
  Range("m" & rownum) = UCase(Range("e11"))
  Range("J" & rownum) = "=I" & rownum & "*g" & rownum
  ActiveWorkbook.RefreshAll
  Call clear
  If Range("S" & rownum) >= 2 Then
      MsgBox "Probably that you made it twice or more, check it please. "
  End If
  If Range("H" & rownum) = "OUT" Then
      Range("I" & rownum) = "=VLOOKUP(D" & rownum & ",Inventory!A:H,7,0)"
  End If
 
  Application.ScreenUpdating = True
End Sub

Sub clear()
  Application.ScreenUpdating = False
  [e6:e10] = ""
  Application.ScreenUpdating = True
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
 
Upvote 0
Thanks for your work, Mr.Dante Amor. I just tried it ,yes it runs a lttle faster than before, but still slowly.. the mouse cursor turns into a rotating circle and like 5 seconds later , it begins to write value into cells.
 
Upvote 0
VBA Code: 
Sub delivery()
If ActiveSheet.FilterMode = True Then
    ActiveSheet.ShowAllData
End If
Application.Calculation = xlCalculationManual
If Range("e3") = "" Then Exit Sub
If Range("e4") = "" Then Exit Sub
If Range("e5") = "" Then Exit Sub
If Range("e6") = "" Then Exit Sub
If Range("e7") = "" Then Exit Sub
If Range("e8") = "" Then Exit Sub
If Range("e11") = "" Then
    MsgBox "请输入供应商或经办人Please input supplier or contacter name"
    Exit Sub
End If
If Range("e2") = "New Item" Then
    rownum = Range("a1048576").End(xlUp).Row + 1
    Range("a" & rownum) = WorksheetFunction.Max([a13:a1048576]) + 1
Else
    rownum = Range("a13:a1048576").Find([e2]).Row
End If
Range("b" & rownum) = Range("e3")
Range("h" & rownum) = Range("e4")
Range("c" & rownum).Value = UCase(Range("e5"))
Range("d" & rownum) = Range("e6")
Range("e" & rownum) = Range("e7")
Range("f" & rownum) = Range("e8")
Range("g" & rownum) = Abs(Range("e10"))
Range("m" & rownum) = UCase(Range("e11"))
Range("J" & rownum) = "=IF(A" & rownum & "="""","""",I" & rownum & "*g" & rownum & ")"
Application.Calculation = xlCalculationAutomatic
Call recheck
End Sub
Sub recheck()
rownum = Range("a1048576").End(xlUp).Row
If Range("S" & rownum) >= 2 Then
    MsgBox "Probably that you made it twice or more, check it please. 您可能重复操作了，请核实!", , "系统提示"
End If
Application.Calculation = xlCalculationManual
If Range("H" & rownum) = "OUT" Then
    Range("I" & rownum) = "=VLOOKUP(D" & rownum & ",Inventory!A:H,7,0)"
End If
Application.Calculation = xlCalculationAutomatic
ActiveWorkbook.RefreshAll
Call clear
End Sub
Sub clear()
[e6:e10] = ""
End Sub

And I just seperated delivery() to two Macro, and test each them of running time, they run really fast if i just do one macro each time.. but when run them together, it became slowly
 
Upvote 0
Maybe try the following for starters:

VBA Code: 
Sub delivery()
'
    Dim lastRow         As Long
    Dim rownum          As Long
    Dim rangeValue      As Range
'
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
'
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
'
    For Each rangeValue In Range("E3:E8")
        If rangeValue.Value = "" Then Exit Sub
    Next
'
    If Range("E11").Value = "" Then
        MsgBox "??????????Please input supplier or contacter name"                              ' <--- Sorry, can't display the Asian characters in my excel version, replace the multiple '?'s
        Exit Sub
    End If
'
    lastRow = Cells(Rows.count, "A").End(xlUp).Row
'
    If Range("E2").Value = "New Item" Then
        rownum = lastRow + 1
        Range("A" & rownum).Value = WorksheetFunction.Max(Range("A13:A" & lastRow)) + 1
    Else
        rownum = Range("A13:A" & lastRow).Find(Range("E2").Value).Row
    End If
'
    With Range("B" & rownum & ":M" & rownum)
        .Value = Array(Range("E3").Value, Range("E4").Value, UCase(Range("E5").Value), Range("E6").Value, Range("E7").Value, Range("E8").Value, Abs(Range("E10").Value), UCase(Range("E11").Value), "=IF(A" & rownum & "="""","""",I" & rownum & "*G" & rownum & ")")
    End With
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
'
    Call recheck
End Sub
 
Upvote 0
Solution
I don't know if it will make a difference but change your whole columns checking to only the range that has data
This
Code: 
rownum = Range("a14:a1048576").Find([e2]).Row
Should become
Code: 
lr = Cells(Rows.Count, 1).End(xlUp).Row
rownum = Range("a14:a" & lr).Find([e2]).Row

I did not look at johnnyL's code but I assume he/she might have something similar.

But aside from that, instead of forcing people to find problems in something that does not work properly, take some time to explain in a concise manner, without leaving anything out, what you would like to achieve.
Everybody has their own way of getting to the finish line.
 
Upvote 0
johnnyL said:
Maybe try the following for starters:

VBA Code: 
Sub delivery()
'
    Dim lastRow         As Long
    Dim rownum          As Long
    Dim rangeValue      As Range
'
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
'
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
'
    For Each rangeValue In Range("E3:E8")
        If rangeValue.Value = "" Then Exit Sub
    Next
'
    If Range("E11").Value = "" Then
        MsgBox "??????????Please input supplier or contacter name"                              ' <--- Sorry, can't display the Asian characters in my excel version, replace the multiple '?'s
        Exit Sub
    End If
'
    lastRow = Cells(Rows.count, "A").End(xlUp).Row
'
    If Range("E2").Value = "New Item" Then
        rownum = lastRow + 1
        Range("A" & rownum).Value = WorksheetFunction.Max(Range("A13:A" & lastRow)) + 1
    Else
        rownum = Range("A13:A" & lastRow).Find(Range("E2").Value).Row
    End If
'
    With Range("B" & rownum & ":M" & rownum)
        .Value = Array(Range("E3").Value, Range("E4").Value, UCase(Range("E5").Value), Range("E6").Value, Range("E7").Value, Range("E8").Value, Abs(Range("E10").Value), UCase(Range("E11").Value), "=IF(A" & rownum & "="""","""",I" & rownum & "*G" & rownum & ")")
    End With
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
'
    Call recheck
End Sub
Click to expand...
Thanks for your work,Johnny. Its better than before ,but I think the problem is recheck() part, I did test for them, and I don't know why that they all run very fast if I run each of them alone, but when I run them together, the speed became slow. and the recheck () part took a few seconds to finish. and delivery() part in 1 sec. could you help me figure it out
 
Upvote 0
jolivanes said:
I don't know if it will make a difference but change your whole columns checking to only the range that has data
This
Code: 
rownum = Range("a14:a1048576").Find([e2]).Row
Should become
Code: 
lr = Cells(Rows.Count, 1).End(xlUp).Row
rownum = Range("a14:a" & lr).Find([e2]).Row

I did not look at johnnyL's code but I assume he/she might have something similar.

But aside from that, instead of forcing people to find problems in something that does not work properly, take some time to explain in a concise manner, without leaving anything out, what you would like to achieve.
Everybody has their own way of getting to the finish line.
Click to expand...


Thanks for your suggestion! Jolivanes , its really a good suggestion so I corrected my code! : )
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Solved
(code adjustment needed) Importing data from multiple .csv files to individual column entries
Replies
2
Views
672
Itshouldbeonebutton
I
B
  • Question Question
VBA Code to Send Mail to skip blank cells
Replies
1
Views
274
Micron
M
I
  • Solved
Replaced CLICK event for CALL event but now see Run time error
Replies
6
Views
286
igold
igold
I
  • Question Question
Receive Automation error when running code & values added to sheet twice
2
Replies
13
Views
430
NoSparks
N
B
  • Question Question
Error message when copying and renaming a worksheet
2
Replies
13
Views
297
smozgur
smozgur

Forum statistics

Threads
1,223,894
Messages
6,175,254
Members
452,624
Latest member
gregg777

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top