VBA macro optimization

S

Szukowny

New Member
Joined
Feb 16, 2023
Messages
5
Office Version
  1. 2013
  2. 2011
  3. 2010
  4. 2007
Platform
  1. Windows
Hi Everyone , I'm new to macros etc , I have did the code which is serving the purpose , but it is slow , is there any chance anyone could help me optimize the code below? Thanks :

Sub NavigateToApplicationWindow()
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim i As Integer
Dim e As Long
Dim rng As Range
Dim cell As Range
Dim duplicateFound As Boolean
Dim ws As Worksheet
Set ws = ActiveSheet
Dim lastRow As Long

Set rng = Range("A2:A100")

' Wait for the window to become active
Application.Wait (Now + TimeValue("0:00:02"))
' Activate the SAPlogon.exe application window with the title "SAP logon"
AppActivate "List of Outbound Deliveries"
' Wait for the window to become active
Application.Wait (Now + TimeValue("0:00:02"))

' Send the key arrow up
SendKeys "^{RIGHT 2}"

' Send the key arrow right
SendKeys "{F2}"
Application.Wait (Now + TimeValue("0:00:02"))
' Send the key arrow down
SendKeys "+{RIGHT 11}"


Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "A").End(xlUp).Row + 1

Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "A").PasteSpecial

Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{TAB 3}"
SendKeys "^{UP}"
SendKeys "+{Left 2}"


Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "B").End(xlUp).Row + 1

Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "B").PasteSpecial

Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^{UP}"
SendKeys "+{RIGHT 3}"



Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "C").End(xlUp).Row + 1

Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "C").PasteSpecial

Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{ESC}"
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{DOWN}"
Application.Wait (Now + TimeValue("0:00:01"))

Do While i <= 100

SendKeys "{F2}"
Application.Wait (Now + TimeValue("0:00:02"))
' Send the key arrow down
SendKeys "+{RIGHT 11}"


Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "A").End(xlUp).Row + 1

Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "A").PasteSpecial

Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{TAB 3}"

SendKeys "^{UP}"
SendKeys "+{Left 2}"


Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "B").End(xlUp).Row + 1

Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "B").PasteSpecial

Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^{UP}"
SendKeys "+{RIGHT 7}"


Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "C").End(xlUp).Row + 1

Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "C").PasteSpecial

Application.Wait (Now + TimeValue("0:00:01"))

For Each cell In rng
If Application.CountIf(rng, cell.Value) > 1 Then
duplicateFound = True
Exit Do
End If
Next cell

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{ESC}"
Application.Wait (Now + TimeValue("0:00:02"))
SendKeys "{DOWN}"
Application.Wait (Now + TimeValue("0:00:01"))


Loop

lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
For e = lastRow To 2 Step -1 ' Loop through each row from bottom to top
If ws.Range("B" & e).Value <> 0 Or ws.Range("C" & e).Value <> 0 Then ' Check if values in columns B and C are not 0
ws.Rows(e).Delete ' Delete the row if values in columns B and C are not 0
End If
Next e


Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

MsgBox "Finish"

End Sub
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
Sort by date Sort by votes
There are a bunch of wait statements in there that may not be needed...expecially between tasks that Excel is doing. I have commented out a bunch. I didn't get rid of any between your SendKeys as those will be dependent on the response time of the other application. You can experiment taking them out 1 at a time and see if it still functions correctly.

VBA Code: 
Sub NavigateToApplicationWindow()
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim i As Integer
Dim e As Long
Dim rng As Range
Dim cell As Range
Dim duplicateFound As Boolean
Dim ws As Worksheet
Set ws = ActiveSheet
Dim lastRow As Long

Set rng = Range("A2:A100")

' Wait for the window to become active
'Application.Wait (Now + TimeValue("0:00:02"))
' Activate the SAPlogon.exe application window with the title "SAP logon"
AppActivate "List of Outbound Deliveries"
' Wait for the window to become active
Application.Wait (Now + TimeValue("0:00:02"))

' Send the key arrow up
SendKeys "^{RIGHT 2}"

' Send the key arrow right
SendKeys "{F2}"
Application.Wait (Now + TimeValue("0:00:02"))
' Send the key arrow down
SendKeys "+{RIGHT 11}"


Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "A").End(xlUp).Row + 1

'Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "A").PasteSpecial

'Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{TAB 3}"
SendKeys "^{UP}"
SendKeys "+{Left 2}"


Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "B").End(xlUp).Row + 1

'Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "B").PasteSpecial

'Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^{UP}"
SendKeys "+{RIGHT 3}"



Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "C").End(xlUp).Row + 1

'Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "C").PasteSpecial

'Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{ESC}"
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{DOWN}"
Application.Wait (Now + TimeValue("0:00:01"))

Do While i <= 100

SendKeys "{F2}"
Application.Wait (Now + TimeValue("0:00:02"))
' Send the key arrow down
SendKeys "+{RIGHT 11}"


Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "A").End(xlUp).Row + 1

'Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "A").PasteSpecial

'Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{TAB 3}"

SendKeys "^{UP}"
SendKeys "+{Left 2}"


Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "B").End(xlUp).Row + 1

'Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "B").PasteSpecial

'Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^{UP}"
SendKeys "+{RIGHT 7}"


Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "C").End(xlUp).Row + 1

'Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "C").PasteSpecial

'Application.Wait (Now + TimeValue("0:00:01"))

For Each cell In rng
If Application.CountIf(rng, cell.Value) > 1 Then
duplicateFound = True
Exit Do
End If
Next cell

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{ESC}"
Application.Wait (Now + TimeValue("0:00:02"))
SendKeys "{DOWN}"
Application.Wait (Now + TimeValue("0:00:01"))


Loop

lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
For e = lastRow To 2 Step -1 ' Loop through each row from bottom to top
If ws.Range("B" & e).Value <> 0 Or ws.Range("C" & e).Value <> 0 Then ' Check if values in columns B and C are not 0
ws.Rows(e).Delete ' Delete the row if values in columns B and C are not 0
End If
Next e


Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

MsgBox "Finish"

End Sub
 
Upvote 0
Candyman8019 said:
There are a bunch of wait statements in there that may not be needed...expecially between tasks that Excel is doing. I have commented out a bunch. I didn't get rid of any between your SendKeys as those will be dependent on the response time of the other application. You can experiment taking them out 1 at a time and see if it still functions correctly.

VBA Code: 
Sub NavigateToApplicationWindow()
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim i As Integer
Dim e As Long
Dim rng As Range
Dim cell As Range
Dim duplicateFound As Boolean
Dim ws As Worksheet
Set ws = ActiveSheet
Dim lastRow As Long

Set rng = Range("A2:A100")

' Wait for the window to become active
'Application.Wait (Now + TimeValue("0:00:02"))
' Activate the SAPlogon.exe application window with the title "SAP logon"
AppActivate "List of Outbound Deliveries"
' Wait for the window to become active
Application.Wait (Now + TimeValue("0:00:02"))

' Send the key arrow up
SendKeys "^{RIGHT 2}"

' Send the key arrow right
SendKeys "{F2}"
Application.Wait (Now + TimeValue("0:00:02"))
' Send the key arrow down
SendKeys "+{RIGHT 11}"


Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "A").End(xlUp).Row + 1

'Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "A").PasteSpecial

'Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{TAB 3}"
SendKeys "^{UP}"
SendKeys "+{Left 2}"


Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "B").End(xlUp).Row + 1

'Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "B").PasteSpecial

'Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^{UP}"
SendKeys "+{RIGHT 3}"



Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "C").End(xlUp).Row + 1

'Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "C").PasteSpecial

'Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{ESC}"
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{DOWN}"
Application.Wait (Now + TimeValue("0:00:01"))

Do While i <= 100

SendKeys "{F2}"
Application.Wait (Now + TimeValue("0:00:02"))
' Send the key arrow down
SendKeys "+{RIGHT 11}"


Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "A").End(xlUp).Row + 1

'Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "A").PasteSpecial

'Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{TAB 3}"

SendKeys "^{UP}"
SendKeys "+{Left 2}"


Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "B").End(xlUp).Row + 1

'Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "B").PasteSpecial

'Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^{UP}"
SendKeys "+{RIGHT 7}"


Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "^c"

AppActivate "Microsoft Excel"

ThisWorkbook.Sheets("Left To Pack").Activate

lastRow = ThisWorkbook.Sheets("Left To Pack").Cells(Rows.Count, "C").End(xlUp).Row + 1

'Application.Wait (Now + TimeValue("0:00:01"))

ThisWorkbook.Sheets("Left To Pack").Cells(lastRow, "C").PasteSpecial

'Application.Wait (Now + TimeValue("0:00:01"))

For Each cell In rng
If Application.CountIf(rng, cell.Value) > 1 Then
duplicateFound = True
Exit Do
End If
Next cell

SendKeys "%{TAB}"
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{ESC}"
Application.Wait (Now + TimeValue("0:00:02"))
SendKeys "{DOWN}"
Application.Wait (Now + TimeValue("0:00:01"))


Loop

lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
For e = lastRow To 2 Step -1 ' Loop through each row from bottom to top
If ws.Range("B" & e).Value <> 0 Or ws.Range("C" & e).Value <> 0 Then ' Check if values in columns B and C are not 0
ws.Rows(e).Delete ' Delete the row if values in columns B and C are not 0
End If
Next e


Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

MsgBox "Finish"

End Sub
Click to expand...
Candyman , Thank You , I have played with it and it causes macro to crash when some timings are removed , the same happened with your improvement above , any other ways?
 
Upvote 0
what line does it crash at? You can use F8 to step through the code. Wherever it is failing, add a small wait time back and move on to the next. At the end of the day, you don't wait the wait statements unless they are absolutely needed. Those wait statements alone add 37 seconds to your runtime...
 
Upvote 0
Candyman8019 said:
what line does it crash at? You can use F8 to step through the code. Wherever it is failing, add a small wait time back and move on to the next. At the end of the day, you don't wait the wait statements unless they are absolutely needed. Those wait statements alone add 37 seconds to your runtime...
Click to expand...
Candyman , sorry ,to be more specific it doesn't crash on the line it goes out of the loop and finishes but it is not putting the correct numbers to correct cells and after few loops goes to finish msg box
 
Upvote 0
Ah, okay...so if you do require those 37seconds of wait time...there's not much you can do to speed that up. Unless you can get better response time out of SAP.
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question
Event code to give message box and change color of auto-shape
Replies
4
Views
153
bh24524
B
sanantonio
  • Solved
VBA Loop Help - A Fresh one!
2
Replies
15
Views
1K
NateSC
NateSC
O
  • Question
Another problem reading HTML-page
Replies
2
Views
176
Oldfox
O
Carlosjunior
  • Question
How to make two or more cells blink in VBA Excel . I have this code below and I'm not getting it, I ask for help
Replies
1
Views
309
Logit
Logit
P
  • Question
Send messages through whatsapp
Replies
1
Views
1K
FormR
FormR

Forum statistics

Threads
1,214,883
Messages
6,122,077
Members
449,064
Latest member
MattDRT

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