Excel VBA - For Loop taking far too long to execute - vba

I have a script which I have designed in order to hide rows that do not contain data, the script looks through column A starting from Row 7. If it finds rows that do not contain values, it will hide those rows from sight. Unfortunately this script takes over 1 minute to run on large sheets in its present form.
Does anybody have suggestions on how to re-write this script in order to make it faster? It needs to run in 5 seconds max
Sub hideAllRows()
Dim Checklist As Variant
UnlockSheet
Call Show_Hide("Row", "7:519", True)
Call Show_Hide("Row", "529:1268", True)
Checklist = ActiveSheet.Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value
For I = UBound(Checklist, 1) To LBound(Checklist, 1) Step -1
If Checklist(I, 1) <> "" Then
Rows(I & ":" & I).Select
Selection.EntireRow.Hidden = False
End If
Next I

I have edited your code in order to make things simpler.
One of the issues is that your code is firing events "like crazy" (each time you do a Select, an event is fired).
A. If you want to use your code as is, I suggest you add at the beginning
Application.EnableEvents = False
and add in the last line:
Application.EnableEvents = true
B. I suggest that you do the hiding "in one blow", after the loop has ended. Here is how:
Dim Checklist As Variant
dim sRowsToHide as string
UnlockSheet
Application.ScreenUpdating = False
Call Show_Hide("Row", "7:519", True)
Call Show_Hide("Row", "529:1268", True)
Checklist = ActiveSheet.Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value
For I = UBound(Checklist, 1) To LBound(Checklist, 1) Step -1
If Checklist(I, 1) <> "" Then
if sRowsToHide = "" then
sRowsToHide = I & ":" & I
else
sRowsToHide = sRowsToHide & "," & I & ":" & I
end if
End If
Next I
ActiveSheet.Range(sRowsToHide).EntireRow.Hidden = True
Application.ScreenUpdating = True
You can use the following line to see how such a thing would work:
ActiveSheet.Range("2:2,14:14,17:17,19:19").EntireRow.Hidden = True

You can try using ScreenUpdating, it will only update the sheet once the loop is done instead of updating every time
Dim Checklist As Variant
UnlockSheet
Application.ScreenUpdating = False
Call Show_Hide("Row", "7:519", True)
Call Show_Hide("Row", "529:1268", True)
Checklist = ActiveSheet.Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value
For I = UBound(Checklist, 1) To LBound(Checklist, 1) Step -1
If Checklist(I, 1) <> "" Then
Rows(I & ":" & I).Select
Selection.EntireRow.Hidden = False
End If
Next I
Application.ScreenUpdating = True

The following will hide all rows that have constants (e.g. typed values) in column A.
Sub hide_A_values()
With ActiveSheet.Columns("A")
.SpecialCells(xlCellTypeConstants).EntireRow.Hidden = True
End With
End Sub
This next one will hide all rows that have formulas in column A.
Sub hide_A_values()
With ActiveSheet.Columns("A")
.SpecialCells(xlCellTypeFormulas).EntireRow.Hidden = True
End With
End Sub
Finally, this will hide all rows that have constants (e.g. typed values) or formulas in column A.
Sub hide_A_values()
With ActiveSheet.Columns("A")
Union(.SpecialCells(xlCellTypeConstants), .SpecialCells(xlCellTypeFormulas)).EntireRow.Hidden = True
End With
End Sub
The problem is that you have to provide error control or risk dealing with the dreaded Runtime error: 1004 No cells were found if there are no constants or formulas to hide. On Error Resume Next typically takes care of this.
Sub hide_A_values()
With ActiveSheet.Columns("A")
On Error Resume Next
.SpecialCells(xlCellTypeConstants).EntireRow.Hidden = True
.SpecialCells(xlCellTypeFormulas).EntireRow.Hidden = True
On Error GoTo 0
End With
End Sub
The only case not covered by those is formulas returning empty strings (e.g. "") which are not considered truly blank.

Related

Hiding Empty Cells

I'm currently working on a code that hides empty cells ,but the problem is i want it to start hiding at a certain range ("A9:A12") not at the beginning of the sheet.
here is my program :
Sub EmptyRow()
'Dim s As String
po = Range("A9:A12").Count
Range("A8").Activate
For i = 1 To po
s = i & ":" & i
If IsEmpty(Cells(i, 1).Value) Then
Rows(s).Select
Selection.EntireRow.Hidden = True
End If
Next
End Sub
The program keeps on hiding cells from the beginning, how do I set it up so it deletes from the range i want it to. Please help.
You can even make your code shorter like this:
For i = 9 To 12
Cells(i, 1).EntireRow.Hidden = IsEmpty(Cells(i, 1).Value)
Next i
Thus, the result of the Hidden property would be dependent on whether the Cells(i,1) is empty. It is easier to understand and to maintain.
Check the solution below. In case you need to change your affected area, just change the value of targetRange.
Sub EmptyRow()
Dim targetRange as Range, po as Long, i as Long
Set targetRange = Range("A9:A12")
po = targetRange.Count
With targetRange
For i = 1 To po
If IsEmpty(.Cells(i, 1).Value) Then
.Rows(i).EntireRow.Hidden = True
End If
Next
End With
End Sub
Sheets("Sheet1").Range("A9:A12").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
SpecialCells results in run-time error if no cells are found, but that can be checked:
If [CountBlank(Sheet1!A9:A12)] Then _
[Sheet1!A9:A12].SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
or ignored:
On Error Resume Next
[Sheet1!A9:A12].SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
You can get rid of bits like select
Sub EmptyRow()
For i = 9 To 12
If IsEmpty(Cells(i, 1).Value) Then
Cells(i, 1).EntireRow.Hidden = True
End If
Next i
End Sub

Excel Worksheet Split

So I need a bit of help with an existing macro.
I need to split a workbook's multiple worksheets into multiple files (not based on worksheet name).
The project: It deals with very sensitive HR/performance data, and I need to send 1000s of employees' data to their individual managers (about 100 managers who can only see their team's data, and no one else's), so I need about 100 files split (1 for each manager).
The file:
- Many different tabs, separated by role.
- First column is a unique identifier made by concatenating the Manager's name with the job title ex. John Stevens_Office Manager
The task: John Stevens will have team members in many different job roles, and needs all that data in one file, separated into tabs by job role. My current macro does half of this (splits the file, but does not unite).
It also doesn't delete out the other tabs from the file...and its a big file with about 50 tabs. Even just some help deleting the other tabs would be greatly appreciated. Also, the data is populated via VLookup, and every time it splits a file it gives me a message asking if I want to update the links? Can the updates be turned on permanently so it splits without any manual input?
Below is some sample data. Please keep in mind that the actual file is far more complex (at least 50 columns)
Sample Data
Sub SplitWB()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ActiveWorkbook.Save
Dim OutputFolderName As String
OutputFolderName = ""
Set myDlg = Application.FileDialog(msoFileDialogFolderPicker)
myDlg.AllowMultiSelect = False
myDlg.Title = "Select Output Folder for Touchstone Files:"
If myDlg.Show = -1 Then OutputFolderName = myDlg.SelectedItems(1) & "\" Else Exit Sub
Set myDlg = Nothing
Application.CutCopyMode = False
'''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''
Dim d As Object, c As range, k, tmp As String, unique(500)
i = 0
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set d = CreateObject("scripting.dictionary")
For Each c In range(Cells(1, 1), Cells(lastRow, 1))
tmp = Trim(c.Value)
If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
Next c
For Each k In d.keys
Debug.Print k, d(k)
i = i + 1
unique(i) = k
Next k
UniqueCount = i
'start deleting
For i = 1 To UniqueCount
'Actions for new workbook
wpath = Application.ActiveWorkbook.FullName
wbook = ActiveWorkbook.Name
wsheet = ActiveSheet.Name
ActiveWorkbook.SaveAs Filename:=OutputFolderName & unique(i), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
For j = 1 To lastRow
If range("A" & j) <> "" And range("A" & j) <> unique(i) Then
Rows(j).Delete
j = j - 1
End If
Next
'hide helper columns
' If HideC = False And DeleteC = True Then
Columns("A:D").Hidden = True
' End If
'
range("E8").Select
'Select Instructions tab
'Worksheets("Guidelines").Activate
'Save new workbook
ActiveWorkbook.Close SaveChanges:=True
Workbooks.Open (wpath)
'ActiveWorkbook.Close False
Workbooks(wbook).Activate
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("Macro has completed successfully!" & vbNewLine & vbNewLine & "Generated files can be found in the following directory:" & vbNewLine & OutputFolderName)
End Sub
Thank you! Have a great day!
Partial Answer: Put this at the top of your code: application.AskToUpdateLinks = False and this at the end application.AskToUpdateLinks = true.
So i think you have a lot of extra code that may not be needed. i'm going to start out small b/c i'm not sure i fully understand the task at hand.
First, i'm going to create an array for all names in column A. Next, i'm going to iterate through the array just for the unique values
Sub SplitWB()
Dim namesArray As Variant
Dim uniqueDict As New dictionary
namesArray = Range("a1:a4") 'hardcoded the range for now
Set uniqueDict = New dictionary
For x = LBound(namesArray) To UBound(namesArray)
If Not uniqueDict.Exists(x) Then uniqueDict.Add x, namesArray (x, 1)
Next x
End Sub
The above may not do anything for you just yet, but i notice you're doing unique for loops, etc which aren't necessary. Just trying to condense your code for ease of debugging.
Once you respond to this, we can work on the next part (you may want to update your code if you use my solution above to create a unique dictionary)

Speed up excel formatting vba code?

I am using the following vba code to change a text string date into an actual date in excel so I can use it for logical comparisons and the like.
The problem is I need this to work for around 4000 rows and update it weekly, and this code is very slow.
Sub Datechange()
Dim c As Range
For Each c In Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row)
c.Value = CDate(c.Value)
Next c
End Sub
Are there any alternative ways I could do the same thing quicker? I am assuming part of the reason it is so slow is because there are overheads involved with selecting single cells and processing the code over and over but I am not sure how to do it any other way?
Also some of the rows at the bottom contain the words "None Specified" and when the code reaches these cells it breaks with
Run-time error '13': Type mismatch
Is there a way to stop this happening so the following code can complete?
First steps would be:
Turn screen updating off
Turn calculation off
Read and write the range at once
It could look like the code below - it is a good idea to include an error handler to avoid leaving your spreadsheet with screen updates off or with the calculation mode changed:
Sub Datechange()
On Error GoTo error_handler
Dim initialMode As Long
initialMode = Application.Calculation 'save calculation mode
Application.Calculation = xlCalculationManual 'turn calculation to manual
Application.ScreenUpdating = False 'turn off screen updating
Dim data As Variant
Dim i As Long
'copy range to an array
data = Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row)
For i = LBound(data, 1) To UBound(data, 1)
'modify the array if the value looks like a date, else skip it
If IsDate(data(i, 1)) Then data(i, 1) = CDate(data(i, 1))
Next i
'copy array back to range
Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row) = data
exit_door:
Application.ScreenUpdating = True 'turn screen updating on
Application.Calculation = initialMode 'restore original calculation mode
Exit Sub
error_handler:
'if there is an error, let the user know
MsgBox "Error encountered on line " & i + 1 & ": " & Err.Description
Resume exit_door 'don't forget the exit door to restore the calculation mode
End Sub
It would be better to get the values in to an array in one single "pull", operate on the array and write it back.
That would circumvent the expensive range operation.
dim c as range
set c = Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row)
dim ArrValue() as Variant
set ArrValue = c.value
next step: iterate over that array and then write back:
c.value = Arrvalue
I have no time to test the code, so please correct it for yourself, I am sorry.

Continue For loop

I have the following code
For x = LBound(arr) To UBound(arr)
sname = arr(x)
If instr(sname, "Configuration item") Then
'**(here i want to go to next x in loop and not complete the code below)**
'// other code to copy past and do various stuff
Next x
So I thought I could simply have the statement Then Next x, but this gives a "no for statement declared" error.
So what can I put after the If instr(sname, "Configuration item") Then to make it proceed to the next value for x?
You can use a GoTo:
Do
'... do stuff your loop will be doing
' skip to the end of the loop if necessary:
If <condition-to-go-to-next-iteration> Then GoTo ContinueLoop
'... do other stuff if the condition is not met
ContinueLoop:
Loop
You're thinking of a continue statement like Java's or Python's, but VBA has no such native statement, and you can't use VBA's Next like that.
You could achieve something like what you're trying to do using a GoTo statement instead, but really, GoTo should be reserved for cases where the alternatives are contrived and impractical.
In your case with a single "continue" condition, there's a really simple, clean, and readable alternative:
If Not InStr(sname, "Configuration item") Then
'// other code to copy paste and do various stuff
End If
For i=1 To 10
Do
'Do everything in here and
If I_Dont_Want_Finish_This_Loop Then
Exit Do
End If
'Of course, if I do want to finish it,
'I put more stuff here, and then...
Loop While False 'quit after one loop
Next i
A lot of years after... I like this one:
For x = LBound(arr) To UBound(arr): Do
sname = arr(x)
If instr(sname, "Configuration item") Then Exit Do
'// other code to copy past and do various stuff
Loop While False: Next x
A few years late, but here is another alternative.
For x = LBound(arr) To UBound(arr)
sname = arr(x)
If InStr(sname, "Configuration item") Then
'Do nothing here, which automatically go to the next iteration
Else
'Code to perform the required action
End If
Next x
And many years later :D I used a "select" statement for a simple example:
For Each zThisRow In zRowRange
zRowNum = zThisRow.Row
Select Case zRowNum
Case 1 '- Skip header row and any other rows to skip -----
'- no need to put anything here -----
Case Else '- Rows to process -----
'- Process for stuff to do something here -----
End Select
Next zThisRow
You can make this as complex as you wish by turning each "if" result into a value (maybe a bit of over complex code would help explain :D ):
zSkip = 0
If 'condition1 = skip' Then zSkip = zSkip + 1
If 'condition2 = skip' Then zSkip = zSkip + 1
If 'condition3 = skip' Then zSkip = zSkip + 1
Select Case zRowNum
Case 0 '- Stuff to do -----
Case Else '- Stuff to skip -----
End Select
It's just a suggestion; have a great Christmas peeps!
This can also be solved using a boolean.
For Each rngCol In rngAll.Columns
doCol = False '<==== Resets to False at top of each column
For Each cell In Selection
If cell.row = 1 Then
If thisColumnShouldBeProcessed Then doCol = True
End If
If doCol Then
'Do what you want to do to each cell in this column
End If
Next cell
Next rngCol
For example, here is the full example that:
(1) Identifies range of used cells on worksheet
(2) Loops through each column
(3) IF column title is an accepted title, Loops through all cells in the column
Sub HowToSkipForLoopIfConditionNotMet()
Dim rngCol, rngAll, cell As Range, cnt As Long, doCol, cellValType As Boolean
Set rngAll = Range("A1").CurrentRegion
'MsgBox R.Address(0, 0), , "All data"
cnt = 0
For Each rngCol In rngAll.Columns
rngCol.Select
doCol = False
For Each cell In Selection
If cell.row = 1 Then
If cell.Value = "AnAllowedColumnTitle" Then doCol = True
End If
If doCol Then '<============== THIS LINE ==========
cnt = cnt + 1
Debug.Print ("[" & cell.Value & "]" & " / " & cell.Address & " / " & cell.Column & " / " & cell.row)
If cnt > 5 Then End '<=== NOT NEEDED. Just prevents too much demo output.
End If
Next cell
Next rngCol
End Sub
Note: If you didn't immediately catch it, the line If docol Then is your inverted CONTINUE. That is, if doCol remains False, the script CONTINUES to the next cell and doesn't do anything.
Certainly not as fast/efficient as a proper continue or next for statement, but the end result is as close as I've been able to get.
you can do that by simple way, simply change the variable value that used in for loop to the end value as shown in example
Sub TEST_ONLY()
For i = 1 To 10
ActiveSheet.Cells(i, 1).Value = i
If i = 5 Then
i = 10
End If
Next i
End Sub
I sometimes do a double do loop:
Do
Do
If I_Don't_Want_to_Finish_This_Loop Then Exit Do
Exit Do
Loop
Loop Until Done
This avoids having "goto spaghetti"

Excel VBA - Compare two Columns in two different sheets then copy/paste - speed - It takes over an hour

Here an absolute beginner at any form of coding, this is the first time ever I try to use VBA.
I have managed after a week and a half of searching and testing and learning to reach the below posted code and I have hit a WALL (and I'm not even done yet!)
What I am trying to achieve:
Compare the data in sheet1 with the data in sheet2 found in Columns K respectively A (there are ca. 55.000 rows in K and 2500 in A) the data might repeat itself as these are product codes and it's ok as at the end of this I want to be able to see which ones have expired.
so .. If K = A then it has to copy adjacent values found in Sheet2 - columns O, P & Q and Paste them in Sheet2 - Columns O, P & Q and if no match is found then right not found. In the Example below I have only tried to copy Q, it would probably take forever if I tried adding O & P.
(Note: I have found this code in one of the forms here and used it after trying different other ways with select/ Copy/ Paste etc. but none have worked)
Later I would like to try adding another column in Sheet1 and based on the Date which will be copied to Sheet1 and into column P populate it with Expired or Soon to be expired depending on the case, but this is an entire different story and I haven't even begun thinking how to do it.
The problem is that my current code takes over an hour and it's still not finished yet while I am writing this!!! And I do not understand where have I gone wrong ....
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim tempVal As String
lastRow1 = Sheets("Sheet1").Range("K" & Rows.Count).End(xlUp).Row
lastRow2 = Sheets("Sheet2").Range("A" & Rows.Count).Row
For sRow = 2 To lastRow1
tempVal = Sheets("MatCode").Cells(sRow, "A").Text
For tRow = 2 To lastRow2
If Sheets("Sheet1").Cells(tRow, "K") = tempVal Then
Sheets("Sheet1").Cells(tRow, "Q") = Sheets("Sheet2").Cells(sRow, "Q")
End If
Next tRow
Next sRow
Dim match As Boolean
'now if no match was found, then put NO MATCH in cell
For lRow = 2 To lastRow2
match = False
tempVal = Sheets("Sheet1").Cells(lRow, "K").Text
For sRow = 2 To lastRow1
If Sheets("Sheet2").Cells(sRow, "A") = tempVal Then
match = True
End If
Next sRow
If match = False Then
Sheets("Sheet1").Cells(lRow, "Q") = "NO MATCH"
End If
Next lRow
End Sub
I have also used:
With Application
.AskToUpdateLinks = False
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
To make sure nothing stands in the way.
Please Help!
This will loop through rows to match column A on Sheet1 with column K on sheet2. On a non-match "No Match" will be put in Sheet1 column Q.
On a match Sheet2 columns O,P and Q will be copied to Sheet1 columns O,P and Q.
This took about 10 seconds to run for over 12k in column A and over 2500 in column K.
Sub match_columns()
Dim I, total, fRow As Integer
Dim found As Range
total = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
For I = 1 To total
answer1 = Worksheets(1).Range("A" & I).Value
Set found = Sheets(2).Columns("K:K").Find(what:=answer1) 'finds a match
If found Is Nothing Then
Worksheets(1).Range("Q" & I).Value = "NO MATCH"
Else
fRow = Sheets(2).Columns("K:K").Find(what:=answer1).Row
Worksheets(1).Range("O" & I).Value = Worksheets(2).Range("O" & fRow).Value
Worksheets(1).Range("P" & I).Value = Worksheets(2).Range("P" & fRow).Value
Worksheets(1).Range("Q" & I).Value = Worksheets(2).Range("Q" & fRow).Value
End If
Next I
End Sub
Thank you again #Mooseman for providing the solution!
I only had to change Range A with K, at first even so I was not able to make it work as it copied only the first line. I already had some code which opened the Worksheets and copied them to a new Worksheet/added new columns ..etc., to be SavedAs for later use, and it seems that because of this your code was not able to loop properly (not sure how to explain this) in any case at the end of the open / save workbooks ..etc I have introduced a Call Sub Procedure which worked like a charm!
Also, introduced two extra lines to properly format columns O and P as Date.
I am sure it could have looked better than this, but so far it works!
And thank you to everyone who provided me with suggestions, there is still a lot to learn and I am planning to test other ways just for the sake of learning, but I needed this to work now.
Sub Button1_Click()
With Application
.AskToUpdateLinks = False
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Code to Open / Save / introduce new columns into Sheet(1)
Call match_columns
End Sub
Sub match_columns()
Dim I, total, frow As Integer
Dim found As Range
total = Sheets(1).Range("K" & Rows.Count).End(xlUp).Row
'MsgBox (total) --> used to test if it can count/see the total number of rows
For I = 2 To total
answer1 = Worksheets(1).Range("K" & I).Value
Set found = Sheets(2).Columns("A:A").Find(what:=answer1) 'finds a match
If found Is Nothing Then
Worksheets(1).Range("Q" & I).Value = "NO MATCH"
Else
frow = Sheets(2).Columns("A:A").Find(what:=answer1).Row
Worksheets(1).Range("O" & I).Value = Worksheets(2).Range("O" & frow).Value
Worksheets(1).Range("P" & I).Value = Worksheets(2).Range("P" & frow).Value
Worksheets(1).Range("Q" & I).Value = Worksheets(2).Range("Q" & frow).Value
End If
Next I
Worksheets(1).Range("P2", "P" & total).NumberFormat = "dd.mm.yyyy"
Worksheets(1).Range("O2", "O" & total).NumberFormat = "dd.mm.yyyy"
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.AskToUpdateLinks = True
.Calculation = xlCalculationAutomatic
End With
End Sub
This is slow because your macro is iterating through 55,000 * 2,500 rows of data, twice. That's 275,000,000 cycles.
I think the solution is to scrap the macro and use VLOOKUP or Index Match.
You could add this formula to cell Q2 of sheet1:
=IFERROR(INDEX(Sheet2!$Q:$Q,MATCH(Sheet1!$K2,Sheet2!$A:$A,0)),"NO MATCH")
That is how I would do this. If you need it to be a macro, you can write a macro that just sets Sheet1 K2 to have this formula and drag the formula down.