VBA taking too long to execute - excel

I have a macro written that clears contents of the active cell row then calls a module to shift the remaining rows up. I am experiencing a long wait time for the macro to finish running. Not sure if this could be written better to execute quicker. The first module is called when a user clicks "Remove Client" on a User Form. Any help would be appreciated. Thank you!
'Called when user clicks Remove Client on User Form
Sub letsgo()
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws = wb.Sheets("contactunder")
ws.Range("C" & ActiveCell.Row & ":BJ" & ActiveCell.Row).ClearContents
Call shiftmeup
End Sub
Sub shiftmeup()
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws = wb.Sheets("contactunder") '/// The underhood of my contacts
With ws.Range("D11:BJ392")
For i = .Rows.Count To 1 Step -1
If IsEmpty(.Cells(i, 1)) Then .Rows(i).Delete Shift:=xlUp
Next
End With
End Sub

Why not change this line:
ws.Range("C" & ActiveCell.Row & ":BJ" & ActiveCell.Row).ClearContents
To this:
ws.Range("C" & ActiveCell.Row & "BJ" & ActiveCell.Row).EntireRow.Delete
This way you can avoid your second sub all together (or keep this as an occasional cleaner rather run it every time you simply need to delete 1 row.)
If you really do need both subs, a common first step for efficiency is to disable screen updating before entering your loop with Application.ScreenUpdating = False and then re-activate it when your loop ends by changing False to True.

This is the followup to urdearboy's answer...
The issue was in your second function and the static range used. You were deleting all the rows at the end, past your data (up to ~380 extra delete row calls). To fix it you should do two things
Only loop to the last row of data
Limit calls to the front end; put all the cells you want to delete into one range and delete it once
Sub ShiftMeUp()
Dim wb As Workbook
Dim ws As Worksheet
Dim DeleteRowRange As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets("contactunder") '/// The underhood of my contacts
For i = 1 To GetLastRow(1, ws)
If IsEmpty(ws.Cells(i, 1)) Then Set DeleteRowRange = MakeUnion(ws.Rows(i), DeleteRowRange)
Next
If Not DeleteRowRange Is Nothing Then DeleteRowRange.EntireRow.Delete Shift:=xlUp
End Sub
I used 2 on my commonly used functions to keep the code clean...
MakeUnion
Public Function MakeUnion(Arg1 As Range, Arg2 As Range) As Range
If Arg1 Is Nothing Then
Set MakeUnion = Arg2
ElseIf Arg2 Is Nothing Then
Set MakeUnion = Arg1
Else
Set MakeUnion = Union(Arg1, Arg2)
End If
End Function
GetLastRow
Public Function GetLastRow(Optional Col As Integer = 1, Optional Sheet As Excel.Worksheet) As Long
If Sheet Is Nothing Then Set Sheet = Application.ActiveSheet
GetLastRow = Sheet.Cells(Sheet.Rows.Count, Col).End(xlUp).Row
End Function

Related

Activate all sheets without flickering through them

I have over 20 sheets with VBA codes that performs calculations realtime and simultaneously. All the calculations on each sheet are working fine except some COUNTIF and FIND ADDRESS function whereby VBA ignores running them on every other sheet unless I'm active on that sheet, then it works.
I have tried several methods and this one works by activating all the sheets from another sub
Worksheets("Sheet2").activate
Worksheets("Sheet3").activate
Worksheets("Sheet4").activate
By doing this, the COUNTIF and FIND ADDRESS functions works on all sheets however, it's flickering through all of the sheets. I was also able to get it to stop on one sheet by adding (Worksheets("Sheet1").activate) at the end of the last sub. This doesn't fix the issue as I am unable to check any other sheet. I also tried
Application.ScreenUpdating = False 'At the beginning of the sub
Application.ScreenUpdating = True 'At the end of the sub
No luck. Tried wrapping each code in the vba around
Dim ws As Worksheets
ws.activate
Doesn't fix the issue. How can I activate all sheets without flickering through them? If activating them all at once can't fix the issue, is there another way? Thank you
Here is the sample of the code -
psup = "Generated" & " " & lBar
If Abs(sp2) = 0 Then
If Cells.Find(psup).Offset(-8, 0).Value > 3 Or Cells(b + 1, h).Offset(-8, 0).Value > 3 Then
Call allNewYes
'Cells(b - 7, h).Value = Cells(b - 7, h).Value + 4
sp2 = 1
End If
End If
'1.Get Position - Generated
If Application.WorksheetFunction.CountIf(ActiveSheet.Cells, psup) > 2 Then
sp6 = Application.WorksheetFunction.CountIf(ActiveSheet.Cells, psup) - 1
Call spLocation
Else
If Application.WorksheetFunction.CountIf(ActiveSheet.Cells, psup) > 0 Then
sp5 = Cells.Find(psup).Address
End If
End If
Sub allNewYes()
Dim locazion As String
Dim FindValue As String
FindValue = psup
Dim FindRng As Range
Set FindRng = Cells.Find(What:=FindValue)
Dim FirstCell As String
FirstCell = FindRng.Address
Do
locazion = FindRng.Address
Range(locazion).Offset(-8, 0).Value = Abs(Range(locazion).Offset(-8, 0).Value) + 4
Set FindRng = Cells.FindNext(FindRng)
Loop While FirstCell <> FindRng.Address
End Sub
Here is a mock-up of how you perform actions on multiple worksheets, without selecting or activating them - using part of your code as an example. I wasn't sure how you create FindValue - so you'd have to do that part yourself.
Sub perform_actions_on_all_sheets()
Dim wb As Workbook, ws As Worksheet, FindRng As Range, FirstCell As String
FindValue = 5 'change this to something appropriate
Set wb = ThisWorkbook
For Each ws In wb.Sheets
If ws.Name <> "ExcludeThisWorksheetName" Then
'do stuff to ws, e.g.
Set FindRng = ws.Cells.Find(What:=FindValue)
If Not (FindRng Is Nothing) Then
FirstCell = FindRng.Address
Do
FindRng.Offset(-8, 0).Value = Abs(FindRng.Offset(-8, 0).Value) + 4
Set FindRng = ws.Cells.Find(FindValue, LookIn:=xlValues, LookAt:=xlWhole)
Loop While FirstCell <> FindRng.Address
End If
End If
Next
End Sub
The If ws.Name <> "ExcludeThisWorksheetName" Then ... End If is optional - this is usually required if you want to run the script on every tab except one.
For anyone experiencing similar issues, by removing (ActiveSheet.Cells) in my code fixed the issue

Using data from another workbook (other than the active one)

Ignoring what my code actually does (it's not important to my question):
I want to be able to open my excel file, press a button, have the code use data in that workbook and another opened workbook (so I would have two workbooks opened at the same time, the macro runs in one of them but can take data from both of them).
The trick here is that I can't seem to find code to access the other workbook that I've opened up, so I can only take info from the active workbook.
For example,
Private Function GetLastRow() As Integer
Dim myLastRow As Integer
Set ws = ThisWorkbook.Sheets("Sheet1")
myLastRow = Range("C" & Rows.count).End(xlUp).Row
GetLastRow = myLastRow
End Function
This code lets me access the active workbook (the one running the code), using ThisWorkbook.
Is there another function capable of allowing me to access another opened workbook?
You could change your function to be more flexible.
Private Function GetLastRow(InWorksheet As Worksheet, InColumn As Variant) As Long
GetLastRow = InWorksheet.Cells(InWorksheet.Rows.Count, InColumn).End(xlUp).Row
End Function
So you can call it …
Sub Test()
Dim LastRow As Long
LastRow = GetLastRow(ThisWorkbook.Worksheet("Sheet1"), "C") 'column as letter
'or
'LastRow = GetLastRow(ThisWorkbook.Worksheet("Sheet1"), 3) 'column as number
End Sub
So you can even run this on another workbook using:
LastRow = GetLastRow(Workbooks("OtherWorkbook.xlsx").Worksheet("Sheet1"), "C") 'column as letter
There is a Workbook object built into VBA that you can use. This documentation should give you the information that you need https://learn.microsoft.com/en-us/office/vba/api/excel.workbook
You would simply put the name of your other workbook in quotes, in parentheses after using the Workbook object (see example on page I hyperlinked). Good luck!
I guess this is what you looking for.
When you have more then one Workbook active you can switch between then.
Sub GetLastRow()
Dim myLastRow As Integer
'Active Workbook
Set ws = ThisWorkbook.Sheets("Plan1")
myLastRow = ws.Range("C" & Rows.Count).End(xlUp).Row
MsgBox myLastRow
'Way when you know workbook name
Workbooks.Open Filename:=ActiveWorkbook.Path & "\Teste1.xlsx"
Set ws1 = Application.Workbooks("Teste1.xlsx").Sheets("Plan1")
myLastRow1 = ws1.Range("C" & Rows.Count).End(xlUp).Row
MsgBox myLastRow1
Dim myLastRow As Integer
'If you don't know the name but, opened after your main Workbook
Set ws3 = Application.Workbooks(2).Sheets("Plan1")
myLastRow3 = ws1.Range("C" & Rows.Count).End(xlUp).Row
MsgBox myLastRow3
End Sub

Delete all except a range of columns excel VBA

I have hundreds of Columns in excel that I don't need. I have a range that I want to keep.
At the minute I have
Sub DeleteClms ()
Range("A:G,L:O").Delete
End Sub
Is there anyway to make this an opposite, in other languages I would simply put a =!.
I have tried putting <> in but I dont know where/how to put it into my code?
Thanks
There is no Excel or VBA function for the Symetric Difference of the columns that I know of.
Here is a quick VBA function to get there. Usage would be DeleteAllBut Range("A:C,H:Q")
Sub DeleteAllBut(rngToKeep As Range)
Dim ws As Worksheet
Dim rngToDelete As Range
Dim rngColi As Range
'Number of columns used in worksheet
Set ws = rngToKeep.Parent
iCols = ws.UsedRange.Columns.Count
FirstOne = True
For i = 1 To iCols
Set rngColi = Range("A:A").Offset(0, i - 1)
If Intersect(rngToKeep, rngColi) Is Nothing Then
If FirstOne Then
Set rngToDelete = rngColi
FirstOne = False
Else
Set rngToDelete = Union(rngColi, rngToDelete)
End If
End If
Next i
Debug.Print rngToDelete.Address & " was deleted from " & ws.Name
rngToDelete.Delete
End Sub

Copy row from another workbook when it has an exact value

I have kind of a basic question. I want to copy rows from workbook "WB1" to workbook "WB" if a cell (i,4) has an exact known value. The code I have tried to write is not working, what can I do do make it work? Hope someone can help me :)
Private Sub CommandButton1_Click()
Dim i As Integer
For i = 8 To 300
If Workbooks("WB1").Worksheets("Commodity Action Plan").Cell(i,4).Value = "Zamet" Then Workbooks("WB1").Worksheets("Commodity Action Plan").EntireRow.Copy
Workbooks("WB2").Worksheets("Action plan").EntireRow.Paste
End If
Next i
End Sub
I copied and checked your code and it wouldn't compile due to a few errors..
Your If statement was on one line, when it should be
If ValueToEvaluate = true Then
'code to execute goes here
End If
or
If ValueToEvaluate = True Then 'code to execute goes here
If you have the full statement on one line then you don't need the End If.
2nd problem is that you are trying to get the entirerow property of a sheet,
Workbooks("WB1").Worksheets("Commodity Action Plan").EntireRow.Copy
this exists on a range object, so you probably wanted something like
Workbooks("WB1").Worksheets("Commodity Action Plan").Rows(i).EntireRow.Copy
Rather than using Paste you can specify a destination (range) as the second argument for the Copy function, which is easier and less prone to errors than the copy & paste 2 stage method.
Try something like:
Private Sub CommandButton1_Click()
Dim i As Long 'Change to long so we don't get an error past row 32767
Dim outRow as Long
Dim sourceWs As Worksheet, destWs As Worksheet
Set sourceWs = Workbooks("WB1").Worksheets("Commodity Action Plan")
Set destWs = Workbooks("WB2").Worksheets("Action plan")
outRow = 1
'For testing
'Set sourceWs = Sheet1
'Set destWs = Sheet2
For i = 8 To 300
If sourceWs.Cells(i, 4).Value = "Zamet" Then
sourceWs.Rows(i).EntireRow.Copy destWs.Rows(outRow)
outRow = outRow + 1
Application.CutCopyMode = False
End If
Next i
End Sub

End(xlUp) only works when the sheet is acive

I have following code
Set wb = ThisWorkbook`
ComboBox7.RowSource = wb.Worksheets("Sheet5").Range("A2", _
Range("A65536").End(xlUp)).Address
If I don't put wb.Sheets("Sheet5").Select before this line, this code throws error
"Application defined or object-defined error"
I want this code to work without selecting the Sheet5.
If I put ComboBox7.RowSource = wb.Worksheets("Sheet5").Range("A2:A7").Address then it works fine without selecting the sheet5.
Is there any way to use End(xlUp) without selecting the sheet?
Yes it is possible.
Logic: Find the last row and then use that to create a range which you can assign to your combobox.
Is this what you are trying?
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim ws As Worksheet
Dim lRow As Long
Dim rng As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet5")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:A" & lRow)
End With
ComboBox5.RowSource = rng.Address
End Sub
The other thing is to do this in one line
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
Set ws = wb.sheets("sheets5")
ComboBox7.RowSource = ws.Range("A2", ws.Range("A65536").End(xlUp)).Address
The second range thinks it is working from the active sheet, you need to tell it otherwise.
Using With is better but this is one line if you are writing code quickly just to get something done.

Resources