Optimize slow code that has lots of "for" and "if" - excel

I have three main sheets: "inputs","variables" and "result". The sheet "inputs" has a list with 150 cells with inputs by the user, the sheet "variable" has a list with more than 30 000 points and "result" is the result of the code.
The code takes a point from the sheet "inputs", searches this point in the "variables" sheet, takes a bunch of information from this sheet an pastes them in the "result" sheet. However the process is really slow, it takes from 7 to 9 minutes to find the 150 inputs. There is any way I can make it faster, or at least half of the time?
The simplified version of the code is shown below, the actual code has at least 5 "for" and 4 "if", due to a lot of conditions presented in the "input" section
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim tag As String
Dim var As String
Dim input As String
Dim i As Integer
Dim j As Integer
Set ws1 = Worksheets("inputs")
Set ws2 = Worksheets("variable")
Set ws3 = Worksheets("result")
For i = 2 To ws2.Range("C" & Rows.count).End(xlUp).Offset(1).Row
For j = b To ws2.Range("C" & Rows.count).End(xlUp).Offset(1).Row
var = ws2.Cells(j, 4)
input = ws1.Cells(i, 2), 12, 40)
If var = specs
DO STAFF HERE
End If
Next j
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

You should try saving into an array the looping through said array! always seems to improve efficiency but a loop inside a loop is never great in terms of O(n2) and all that!
Dim varr As Variant
Dim j as long
varr = ws2.Range("C1:C" & ws2.Range("C" & Rows.count).End(xlUp).Row).value
For j = LBound(varr) To UBound(varr)
If varr(j, 1) = specs then
end if
Next j

Related

Copy and paste data from one sheet to multiple where range matches sheet names

I have an API call that pulls data relating to 34 individual sites. Each site has a varying number of assets within it, each with a unique identifier.
I am trying to write a macro that will copy and paste the data for specific sites into their own individual worksheet within the file. The basic concept of this I am familiar with but I am struggling with the ranges I need to specify.
So basically, I need the macro to work its way down Column A of the sheet called Raw Data and identify any rows where the Site name (Value in column A) matches one of the Sheet names. It should then copy the Rows from A to H with that site name and paste into the respective site sheet in rows A to H.
The values in Column A will always match one of the other sheets in the workbook.
Example image that might help explain a bit better:
Apologies in advance if my explanation is not very clear. I have very limited experience using macros so I am not sure if my way of explaining what I want to achieve is understandable or if at all possible.
I am very keen to learn however and any guidance you fine folk could offer would be very much appreciated.
Welcome!
Try this one
Function ChkSheet(SheetName As String) As Boolean
For i = 1 To Worksheets.Count
If Worksheets(i).Name = SheetName Then
ChkSheet = True
Exit Function
End If
Next
ChkSheet = False
End Function
Sub test()
Dim i, j, k As Long
Dim wsRaw As Worksheet
Dim Aux As String
Set wsRaw = Worksheets("Raw Data")
For i = 1 To wsRaw.Range("A:A").SpecialCells(xlCellTypeLastCell).Row
If ChkSheet(wsRaw.Cells(i, 1).Value2) Then
Aux = wsRaw.Cells(i, 1).Value2
k = Worksheets(Aux).Range("A:A").SpecialCells(xlCellTypeLastCell).Row + 1
For j = 1 To 8
Worksheets(Aux).Cells(i + k, j).Value2 = wsRaw.Cells(i, j).Value2
Next
Else
Worksheets.Add.Name = wsRaw.Cells(i, 1).Value2
Aux = wsRaw.Cells(i, 1).Value2
k = 2
For j = 1 To 8
Worksheets(Aux).Cells(i + k, j).Value2 = wsRaw.Cells(i, j).Value2
Next
End If
Next
End Sub
So the Function ChkSheet will check if the sheet exist (you donĀ“t need to create them) and the procedure test will follow all the items that you have in your "Raw Data" worksheet and it will copy to the last used row of every sheet.
And please, even for a newbie, google, read, get some information and when you get stacked, ask for help. This forum is not for giving solutions with not effort.
Good morning all,
David, thanks very much for your help with this. I really didn't want you to think I was trying to get someone to give me the answer and I had tried a few other things before asking the question, but I neglected to show any evidence of my workings. Rookie mistake and I apologise for this.
Having done a bit more research online and with a good dollop of help from a much more experienced colleague I have got the below code using advance filter which works perfectly for what I need.
I thought I would share it here in case it is of any use to others in the future.
Option Explicit
Dim RawDataCol As String
Dim ListCol As String
Dim AdvRng As String
Dim RawDataRng As String
Dim SiteAbrRng As String
Dim ShiftCols As String
Private Sub SetParameters()
'Cell Address where RawData is pasted to each of the site sheets
RawDataCol = "A2"
'Column where the Unique List is cleared and pasted
ListCol = "L"
'Advanced Filter Range
AdvRng = "A1:K2"
'Pasted Raw Data Columns on each sheet
RawDataRng = "A2:K"
'Site Abr gets pasted to the address during loop
SiteAbrRng = "A2"
'Range that gets deleted after pasting Raw Data to each sheet
ShiftCols = "A2:K2"
End Sub
Sub CopyDataToSheets()
On Error GoTo ErrorHandler
AppSettings (True)
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Dim wbk As Workbook
Dim sht_RawData As Worksheet, sht_target As Worksheet, sht_AdvancedFilter As Worksheet, sht_TurbineData As Worksheet
Dim tbl_RawData As ListObject
Dim LastRow1 As Long, LastRow2 As Long, UniqueListCount As Long
Dim MyArr As Variant
Dim ArrTest As Boolean
Dim x As Long, AdvRowNo As Long
Set wbk = ThisWorkbook
SetParameters
Set sht_RawData = wbk.Worksheets("Raw Data")
Set sht_AdvancedFilter = wbk.Worksheets("Advanced Filter")
Set sht_TurbineData = wbk.Worksheets("Turbine Data")
Set tbl_RawData = sht_RawData.ListObjects("_00")
'clear unqie list of SiteAbr
With sht_TurbineData
LastRow1 = .Cells(Rows.Count, 12).End(xlUp).Row
If LastRow1 > 1 Then
'sht_TurbineData.Range("L1:L" & LastRow1).ClearContents
sht_TurbineData.Range(ListCol & 1 & ":" & ListCol & LastRow1).ClearContents
End If
End With
'Copy Unqiue list of SiteAbr to Turbie Data Sheet
tbl_RawData.Range.Columns(1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=sht_TurbineData.Range(ListCol & 1), _
Unique:=True
LastRow1 = sht_TurbineData.Cells(Rows.Count, sht_TurbineData.Range(ListCol & 1).Column).End(xlUp).Row
'Sort Unique List
sht_TurbineData.Range("L1:L" & LastRow1).Sort _
Key1:=sht_TurbineData.Range("L1"), _
Order1:=xlAscending, _
Header:=xlYes
'Load unique site Abr to array
With sht_TurbineData
'MyArr = Application.Transpose(.Range("L2:L" & LastRow1))
MyArr = Application.Transpose(.Range(ListCol & 2 & ":" & ListCol & LastRow1))
UniqueListCount = LastRow1 - 1
End With
'Test Array conditions for 0 items or 1 item
ArrTest = IsArray(MyArr)
If UniqueListCount = 1 Then
MyArr = Array(MyArr)
ElseIf UniqueListCount = 0 Then
GoTo ExitSub
End If
For x = LBound(MyArr) To UBound(MyArr)
Set sht_target = wbk.Worksheets(MyArr(x))
With sht_target
'Find the last non blank row of the target paste sheet
LastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
'Clear contents if the Last Row is not the header row
If LastRow2 > 1 Then
.Range(RawDataRng & LastRow2).ClearContents
End If
sht_AdvancedFilter.Range(SiteAbrRng) = MyArr(x)
'Filter Source Data and Copy to Target Sheet
tbl_RawData.Range.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=sht_AdvancedFilter.Range(AdvRng), _
CopyToRange:=.Range(RawDataCol), _
Unique:=False
'Remove the first row as this contains the headers
.Range(ShiftCols).Delete xlShiftUp
End With
Next x
ExitSub:
SecondsElapsed = Round(Timer - StartTime, 3)
AppSettings (False)
'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
Exit Sub
ErrorHandler:
MsgBox (Err.Number & vbNewLine & Err.Description)
GoTo ExitSub
End Sub
Sub ClearAllSheets()
Dim tbl_SiteList As ListObject
Dim wbk As Workbook
Dim sht_target As Worksheet, sht_TurbineData As Worksheet
Dim MyArray As Variant
Dim x As Long, LastRow As Long
Set wbk = ThisWorkbook
Set sht_TurbineData = wbk.Worksheets("Turbine Data")
Set tbl_SiteList = sht_TurbineData.ListObjects("SiteList")
SetParameters
MyArray = Application.Transpose(tbl_SiteList.DataBodyRange)
For x = LBound(MyArray) To UBound(MyArray)
Set sht_target = wbk.Worksheets(MyArray(x))
LastRow = sht_target.Cells(Rows.Count, 1).End(xlUp).Row
If LastRow > 1 Then
sht_target.Range("A2:K" & LastRow).ClearContents
End If
Next x
End Sub
Private Sub AppSettings(Opt As Boolean)
If Opt = True Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ElseIf Opt = False Then
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End If
End Sub
Thanks again to all who answered and especially to you David. Although I have only used the basic principles from what you offered, it was extremely useful to help me understand what I needed to do in order to get the data to copy into the correct sheets.
Many thanks,
MrChrisP

Code is not compiling but seems good to me

This section of code should loop through the table of data in the column I tell it to, and if it is not 0 or blank it should copy the whole row of the table to another spreadsheet which is my formatted reports sheet.
This code seems good to me, and I have other similar pieces of code that work fine but this one does not for some reason.
Public Sub getActiveCodes()
Dim tRows
Dim i As Integer
Dim ws As Worksheet, rpts As Worksheet
Dim nxtRow As Integer
Set ws = Worksheets("Sheet1")
Set rpts = Worksheets("REPORTS")
For i = 1 To i = ws.Range("mainTable").Rows.Count
nxtRow = Module1.countRows(rpts)
If ws.ListObjects("mainTable").DataBodyRange(i, 9).Value <> 0_
Or "" Then
ws.ListObjects("mainTable").ListRows(i).Range.Copy
rpts.Range("A:" & nxtRow).PasteSpecial , Paste:=xlPasteValues
End If
Next i
End Sub
I would like this function to make a report of all data pertaining to each row item that is not zero in this column.
Cleaned up the code for you
Public Sub getActiveCodes()
Dim tRows
Dim i As Long, nxtRow As Long
Dim wb As Workbook
Dim ws As Worksheet, rpts As Worksheet
Set wb = Workbooks(REF)
Set ws = wb.Worksheets("Sheet1")
Set rpts = wb.Worksheets("REPORTS")
For i = 1 To ws.Range("mainTable").Rows.Count
nxtRow = Module1.countRows(rpts)
If ws.ListObjects("mainTable").DataBodyRange(i, 9).Value <> 0 _
Or ws.ListObjects("mainTable").DataBodyRange(i, 9).Value <> "" Then
ws.ListObjects("mainTable").ListRows(i).Range.Copy
rpts.Range("A:" & nxtRow).PasteSpecial xlPasteValues
End If
Next i
End Sub
Problem was your underscore and the general If statement. Before a line break, add a space. Moreover you shouldn't do If x = 1 Or 2, you should always include the value you compare it to, so If x = 1 Or x = 2. That is because If x = 1 Or 2 reads as if x = 1 is true or if 2 is true, which will always be true because whether or not x = 1, there is nothing false about the number 2 on its own.
Using the Copy function to just copy values is slow. You're better off equalising the values of two ranges like Range("A1:A20").Value = Range("B2:B21").Value

Why is my VBA SUMIFS function returning zeros?

First, allow me to thank you for any help you are able to lend me. I appreciate it! (:
My issue is this: I have two workbooks, one with raw data, and one in which the raw data is consolidated into relevant statistics. I am trying to SUMIFS the data in X:X in my raw data workbook (6620) by two criteria in the results book and then update the value in the corresponding cell in the results book.
The problem is that the macro returns all zeros. I have double checked the data types, names, ranges, etc, but no luck. Leaving me to think there is something wonky in my code.
I include two photos at the end of this post of example raw data and results tables so you can see what I am working from.
Sub ImportFTEs()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim ws As Integer
Workbooks.Open Filename:=ActiveWorkbook.Path & "\6620\FY19*.xlsb"
For ws = 1 To Worksheets.Count
Sheets(ws).Name = "Sheet1"
Next ws
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim totalFTE As Long
Dim lastRow As Integer
lastRow = Cells(Rows.Count, "D").End(xlUp).Row
Dim wb_a As Worksheet
Set wb_a = Workbooks.Open(ActiveWorkbook.Path & "\FY19*.xlsb").Sheets("Sheet1")
Dim wb_b As Worksheet
Set wb_b = ThisWorkbook.Sheets("B")
Dim sumRange As Range
Set sumRange = wb_a.Range("X:X")
Dim cRange1 As Range
Set cRange1 = wb_a.Range("D:D")
Dim criteria1 As Range
Dim cRange2 As Range
Set cRange2 = wb_a.Range("S:S")
Dim criteria2 As Range
For k = 8 To 18
For l = 7 To 18
For i = 7 To 18
Set criteria1 = wb_b.Cells(7, i)
For j = 8 To 18
Set criteria2 = wb_b.Cells(j, 6)
wb_b.Cells(k, l).value = Application.WorksheetFunction.SumIfs(sumRange, cRange1, criteria1, cRange2, criteria2)
Next j
Next i
Next l
Next k
ActiveWorkbook.Close savechanges:=True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
You don't need so many nested loops. Your original code is looping through every possible criteria for each k and l. Assuming wb_b.Cells(k, l) is supposed to be a reference to the cell intersected by your month column and employee name row, you could use your i and j values.
For i = 7 To 18
Set Criteria1 = wb_b.Cells(7, i)
For j = 8 To 18
Set Criteria2 = wb_b.Cells(j, 6)
wb_b.Cells(j, i).Value = Application.WorksheetFunction.SumIfs(sumRange, cRange1, Criteria1, cRange2, Criteria2)
Next j
Next i

How to add a step function within a dictionary macro

I am new to VBA and I have been using the great help within this site, to create a macro to take a list of numbers from one sheet (Sheet 14), remove the duplicates and paste within another sheet (Sheet 2).
I am hoping to take this further by rather than pasting the cells one after another I am looking to have the list pasted in alternate rows i.e D10, D12, D14 etc.
I have tried various methods from within this site, however to no avail. I have used different types of "Step" functions but I am struggling to incorporate this within the below coding.
Any help is much appreciated!
Below is what I have at the moment:
Sub RUN()
Application.ScreenUpdating = False
Dim lastRow As Long
Dim i As Long
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")
Sheet14.Activate
lastRow = Sheet14.Cells(Rows.Count, "F").End(xlUp).Row
On Error Resume Next
For i = 3 To lastRow
If Len(Cells(i, "F")) <> 0 Then
dictionary.Add Cells(i, "F").Value, 1
End If
Next
Sheet2.Range("d10").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)
Application.ScreenUpdating = True
MsgBox dictionary.Count & " RUN TEMPLATES."
End Sub
Here's one approach (BTW, I wouldn't call a macro RUN):
Sub ListUniques()
Dim lastRow As Long
Dim i As Long
Dim dictionary As Object
Dim vKeys
Application.ScreenUpdating = False
Set dictionary = CreateObject("scripting.dictionary")
With Sheet14
lastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
For i = 3 To lastRow
If Len(.Cells(i, "F")) <> 0 Then
dictionary(.Cells(i, "F").Value) = 1
End If
Next
End With
vKeys = dictionary.keys
For i = LBound(vKeys) To UBound(vKeys)
Sheet2.Range("d10").Offset(2 * i).Value = vKeys(i)
Next i
Application.ScreenUpdating = True
MsgBox dictionary.Count & " RUN TEMPLATES."
End Sub

Fastest way to Delete whole row based on Blank Cell

There are so many ways to delete a whole row based on a blank cell in specific column. What I want to know is which is the fastest way to accomplish this task in terms of Excel speed. I have a sheet with about 39,000 original rows of data which then becomes 21,000 rows after I run the code below. The issue is the chunk of code takes almost 60 seconds to return. While I know CPU and such is a factor, but lets assume all else being equal.
I am using Column A as the total count of rows and Column F as the location of blank cells. Is this the best/ fastest way to write this code?
' Finds the last row with a file numbers and removes the remaining rows
Dim LastRow As Integer
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Range("F2:F" & LastRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Try this (wishing it would help, although take backup of your sheet before!):
Sub FastestBlankRowTerminator()
ActiveSheet.UsedRange.Columns(6).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
One of the simplest things I can advise that should increase performance by a noticeable amount is to turn off screen updating and automatic calculation while running this procedure.
I typically turn these items off at the initial invocation of code and turn them back on after the final one. Meaning I would have one sub to contain a series of other subs and functions that it would execute in sequence. Instead of embedding this in those subs and functions individually I just set them off, execute the main sub, and then reset them.
' Speed Up
application.screenupdating = false
application.calculation = xlCalculationManual
<insert code you want to improve performance on here>
' Slow Down
application.screenupdating = true
application.calculation = xlCalculationAutomatic
I ran a test myself populating column a with a rowcount up to 39000 and then every other record would have a "1" in column f.
It still takes some time but only 46 seconds on my core2duo, if I don't turn off screen updating it takes 3 minutes and 34 seconds.
Sub Main()
' Speed Up
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Begin ' Main Sub
' Reset
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Begin()
' Sub 1
' Sub 2
' Sub 3
Remove_Blanks
End Sub
Sub Remove_Blanks()
Dim dA As Date, dB As Date
Dim wb As Workbook
Dim ws As Worksheet
Dim i As Long, j As Integer
Dim r As Long, c As Integer
dA = Now
' Commented out to indicate they could be here but if you are executing multiple procedures then you should have it occur outside of this.
'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
With ws
For r = 1 To .UsedRange.Rows.Count
If .Cells(r, 6) = "" Then .Rows(r).Delete
Next r
End With
dB = Now
'Commented out for same reason above
'Application.ScreenUpdating = True
'Application.Calculation = xlCalculationAutomatic
Debug.Print "Remove_Blanks: " & Format((dB - dA), "mm/dd/yyyy hh:mm:ss")
End Sub
I set up a matrix of 50,000 rows x 12 columns. In column F I placed about 25,000 blanks randomly placed.
Read the used range into an array
Iterate through the array and read those rows with content in column F into a results array
Clear the original data
write the results array
A lot of steps, but the execution time was less than one second; it would probably be faster with screenupdating false; and longer if you have more columns.
EDIT: Screenupdating false did not significantly decrease the execution speed, which was approximately 0.36 seconds when timed with a hi-res timer.
EDIT2: After reading Tim Williams comment about preserving formatting and formulas, I present a different approach. This approach will use the Advanced Filter and, on the same made up data as above, will place the data on another worksheet minus the rows that have blanks in column F. This does require a first row of column headers in the data; or, at least, that F1 has a unique, non-blank value.
To accomplish that process takes about 0.15 seconds.
If you also want to copy it back over the original worksheet, and delete the added worksheet, that will take about another 0.3 seconds.
Here is some code to do that, but you'd have to alter it for your own specifications:
==============================================
Sub DeleteBlankFRows2()
Dim WS As Worksheet, wsTemp As Worksheet, rTemp As Range
Dim R As Range, rCrit As Range
Dim I As Long
Set WS = Worksheets("Sheet5")
Set R = WS.Range("a1").CurrentRegion
Set rCrit = R.Offset(0, R.Columns.Count + 3).Resize(2, 1)
rCrit(1) = R(1, 6)
rCrit(2) = "<>"
Application.ScreenUpdating = False
Worksheets.Add
Set wsTemp = ActiveSheet
wsTemp.Name = "Temp"
R.AdvancedFilter xlFilterCopy, rCrit, Cells(1, 1)
Set rTemp = wsTemp.Cells(1, 1).CurrentRegion
WS.Cells.Clear
rTemp.Copy WS.Cells(1, 1)
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
=======================================
This was my original code using VBA arrays:
===========================
Sub foo()
Dim vSrc As Variant, vRes() As Variant
Dim rSrc As Range
Dim I As Long, J As Long, K As Long
Dim lRows As Long
'Or may need to use a different method to include everything
Set rSrc = Range("a1").CurrentRegion
vSrc = rSrc
'how many rows to retain
For I = 1 To UBound(vSrc)
If vSrc(I, 6) <> "" Then lRows = lRows + 1
Next I
ReDim vRes(1 To lRows, 1 To UBound(vSrc, 2))
K = 0
For I = 1 To UBound(vSrc)
If vSrc(I, 6) <> "" Then
K = K + 1
For J = 1 To UBound(vSrc, 2)
vRes(K, J) = vSrc(I, J)
Next J
End If
Next I
Cells.Clear
Range("a1").Resize(UBound(vRes, 1), UBound(vRes, 2)) = vRes
End Sub

Resources