I have a code that sorts through thousands of lines in a spreadsheet and when it finds a row that has a specific match in two different columns, it returns a value in a third column. However this UDF is used thousands of times and with each running thousands of loops, its very slow. Is there a way to speed up or make this more efficient?
Dim SearchSheet As Worksheet
Dim PN As Integer
Dim MdlCol As Integer
Dim Mdl As String
Dim Result As Integer
Dim FinalRow As Integer
Dim i As Integer
Application.Volatile True
Select Case True
Case Number < WorksheetFunction.CountA(Sheet2.Range("A:A")) And Model = "1A"
Set SearchSheet = Sheet2
PN = 3
MdlCol = 5
Mdl = "1A"
Result = 30
Case Number < WorksheetFunction.CountA(Sheet2.Range("A:A")) And Model = "1B"
Set SearchSheet = Sheet2
PN = 3
MdlCol = 6
Mdl = "1B"
Result = 30
Case Number < WorksheetFunction.CountA(Sheet2.Range("A:A")) And Model = "1C"
Set SearchSheet = Sheet2
PN = 3
MdlCol = 7
Mdl = "1C"
Result = 30
Case Number >= WorksheetFunction.CountA(Sheet2.Range("A:A")) And Model = "1A"
Set SearchSheet = Sheet3
PN = 2
MdlCol = 18
Mdl = "-1A"
Result = 80
Case Number >= WorksheetFunction.CountA(Sheet2.Range("A:A")) And Model = "1B"
Set SearchSheet = Sheet3
PN = 2
MdlCol = 19
Mdl = "-1B"
Result = 80
Case Number >= WorksheetFunction.CountA(Sheet2.Range("A:A")) And Model = "1C"
Set SearchSheet = Sheet3
PN = 2
MdlCol = 20
Mdl = "-1C"
Result = 80
End Select
FinalRow = WorksheetFunction.CountA(SearchSheet.Range("A:A")) + 10
For i = 2 To FinalRow
If SearchSheet.Cells(i, PN) = PartNumber And SearchSheet.Cells(i, MdlCol) = Mdl Then
If SearchSheet.Cells(i, Result).Value = "X" Then
CalibrationRequired = "Y"
Else
CalibrationRequired = SearchSheet.Cells(i, Result).Value
End If
Exit For
End If
Next i
End Function ```
I would suggest:
put LastARow=WorksheetFunction.CountA(SearchSheet.Range("A:A")) once at the start and re-use LastARow rather than repeating the COUNTA many times.
Instead of looping down to final row and looking at each cell in turn, get all the data into a variant array and loop on that
Avoid the VBE UDF slowdown bug by initiating calculation from VBA
Related
I'm trying to get a set of input data and split them out of various cells once it hits a text limit
For example, the amount of characters in cell A1 is 100
I want to split it such that A1, B1, C1, D1 etc. all contains 10 character each
The input of the 100 characters is coming from a loop that combines entries of multiple cells together
I am able to write a loop that can combine the values into 1 cell
But I'm finding trouble to write it such that Cell A1 should only contain 10 characters before proceeding to Cell B1 to populate the next 10 characters etc.
Sub getReport()
Dim com As New cls_common_funct
Dim result, report, ws As Worksheet
Dim lastrw, length, count, i As Long
Dim exp, strategy As String
Dim firstFlag As Boolean
Set ws = Worksheets(ActiveSheet.Name)
Set result = Worksheets("result")
result.Cells.ClearContents
lastrw = com.FindLastRow_WithinColumn(ws.Name, "A")
exp = ""
firstFlag = False
For i = 3 To lastrw
strategy = ws.Cells(i, 1)
If firstFlag = False Then
exp = strategy
firstFlag = True
Else
exp = exp & ", " & strategy
End If
Next
result.Select
result.Range("A1") = exp
How about this one?
Sub stringmanipulation()
Dim length As Long, count As Long, i As Long
length = Len(Range("A1")) 'gets length of range
count = Application.WorksheetFunction.RoundUp(length / 10, 0) - 1
For i = 1 To count
Cells(1, i + 1) = Left(Range("A1"), 10)
Range("A1") = Right(Range("A1"), length - 10)
length = length - 10
Next i
Cells(1, i + 1) = Range("A1")
Range("A1").ClearContents
End Sub
I have a spreadsheet that lists all permutations of 5 columns of data into a single column of text (Column X aka 24) and my goal is to extract only actual words from that list into its own column (Column Y aka 25). The first part is not performed with VBA and happens almost instantaneously, but the spell check + extracting the actual words takes over an hour to complete (I've had to stop it it after 10 minutes and not even 10% of the way through). Is there a better way to do this?
My lists start on row 6 (n = 6) and Range("V3") is just the number of permutations (in this case, 83,521).
Sub Permute_and_Extract()
n = 6
Range("X7:X1000000").ClearContents
Range("Y6:Y1000000").ClearContents
Max = Range("V3") + 5
Range("X6").Select
Selection.AutoFill Destination:=Range("X6:X" & Max)
For i = 6 To Max
x = Application.CheckSpelling(Cells(i, 24).Text)
If x = True Then
Cells(n, 25) = Cells(i, 24)
n = n + 1
End If
Next i
End Sub
Following from the comments above:
Sub Permute_and_Extract()
Const RNG As String = "F1:F10000"
Dim wlist As Object, t, c As Range, i As Long, arr, res
Dim rngTest As Range
Set rngTest = ActiveSheet.Range(RNG)
t = Timer
Set wlist = WordsList("C:\Temp\words.txt", 5)
Debug.Print "loaded list", Timer - t
Debug.Print wlist.Count, "words"
'using an array approach...
t = Timer
arr = rngTest.Value
For i = 1 To UBound(arr, 1)
res = wlist.exists(arr(i, 1))
Next i
Debug.Print "Array check", Timer - t
'going cell-by-cell...
t = Timer
For Each c In rngTest.Cells
res = wlist.exists(c.Value)
Next c
Debug.Print "Cell by cell", Timer - t
End Sub
'return a dictionary of words of length `wordLen` from file at `fPath`
Function WordsList(fPath As String, wordLen As Long) As Object
Dim dict As Object, s As String
Set dict = CreateObject("scripting.dictionary")
dict.comparemode = vbTextCompare 'case-insensitive !!!
With CreateObject("scripting.filesystemobject").opentextfile(fPath)
Do While Not .AtEndOfStream
s = .readline()
If Len(s) = wordLen Then dict.Add s, True
Loop
.Close
End With
Set WordsList = dict
End Function
Output:
loaded list 0.359375
8938 words
Array check 0.019
Cell by cell 0.030
I'm writing a code that takes the inputs from a user form and populates different worksheets with the data. I store the data from the user form into variables (string or double) but when I populate the worksheets with the information, the macro gets very slow. It takes about 4 seconds to populate each row with my code. I can't figure out myself how to make the code more efficient.
The data is to be pasted in different worksheets (below the code for one worksheet). Within each worksheet, the data is pasted always within the same row (always the first empty line). The columns are fixed and I cannot change them. I have to paste each variable into a particular column, leaving the other columns unchanged.
Dim ordSheet As Worksheet
Set ordSheet = ThisWorkbook.Sheets("Orders")
ord_cNorder = 1
ord_cDate = 2
ord_cNarticles = 5
ord_cImpBI = 6
ord_cImpTax = 7
ord_cSellingCh = 8
ord_cShippingBI = 9
ord_cShippingTax = 10
ord_cCustomer = 11
ord_cCountry = 12
ord_cCity = 13
ord_cNotes = 14
With ordSheet
ord_writeLine = ordSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
If Me.CBx_Cont = False Then
.Cells(ord_writeLine, ord_cNorder).Value = Norder
.Cells(ord_writeLine, ord_cDate).Value = dmyDate
.Cells(ord_writeLine, ord_cNarticles).Value = Narticles
.Cells(ord_writeLine, ord_cImpBI).Value = ImpBI
.Cells(ord_writeLine, ord_cImpTax).Value = ImpTax
.Cells(ord_writeLine, ord_cSellingCh).Value = SellingCh
.Cells(ord_writeLine, ord_cShippingBI).Value = ShippingBI
.Cells(ord_writeLine, ord_cShippingTax).Value = ShippingTax
.Cells(ord_writeLine, ord_cCustomer).Value = Customer
.Cells(ord_writeLine, ord_cNotes).Value = Notes
.Cells(ord_writeLine, ord_cCountry).Value = Country
.Cells(ord_writeLine, ord_cCity).Value = City
Else
.Cells(ord_writeLine, ord_cImpBI).Value = ImpBI
.Cells(ord_writeLine, ord_cImpTax).Value = ImpTax
.Cells(ord_writeLine, ord_cShippingBI).Value = ShippingBI
.Cells(ord_writeLine, ord_cShippingTax).Value = ShippingTax
End If
EDIT 04.Jan.21: Improved but still slow
I changed the code with the suggestions from #bugdrown and #Tim Williams:
Using With ordSheet.Rows(ord_writeLine) instead of With ordSheet
Populating a variant array with the userform data and looping through the array to fill the cells
Deactivating screen updating
Application.ScreenUpdating = False
Dim ordSheet As Worksheet
Set ordSheet = ThisWorkbook.Sheets("Orders")
Dim ord_writeLine As Integer
ord_writeLine = ordSheet.Cells(Rows.Count, 1).End(xlUp).Row+1
Dim ordCols As Variant
Dim ordVals As Variant
Dim ordColsCont As Variant
Dim ordValsCont As Variant
ordCols = Array(1, 2, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)
ordVals = Array(Norder, dmyDate, Narticles, ImpBI, ImpTax, SellingCh, ShippingBI, ShippingTax, Customer, Country, City, Notes)
ordColsCont = Array(6, 7, 9, 10)
ordValsCont = Array(ImpBI, ImpTax, ShippingBI, ShippingTax)
With ordSheet.Rows(ord_writeLine)
If CBx_Cont = False Then
For i = 0 To 11 'I set a timer here to test
.Cells(ordCols(i)).Value = ordVals(i)
Next i
Else
For i = 0 To 3
.Cells(ordColsCont(i)).Value = ordValsCont(i)
Next i
Narticles = Narticles + .Cells(5).Value - 1
.Cells(5).Value = Narticles
End If
Application.ScreenUpdating = True
The total time for this code is now slightly below 3 seconds (25% improvement) but still feels too long.
I put a timer within the if loop and I identified the bottleneck being the first 2 iterations (with aprox. 1.2 seconds each).
The first 2 iterations correspond to Norder (integer) and dmyDate (date).
I can't figure out how to fix it.
I try to learn VBA. This code:
Dim i As Integer
Dim damage As String
i = 1
Do While 1
damage = CStr(Worksheets("charakters").Range("d14").Value)
you_min_damage = CInt(Left(damage, i))
If Right(i, 0) = "-" Then
Trim (you_min_damage)
Exit Do
End If
i = i + 1
Loop
cause this problem (in 4 iteration):
In cell D14 I have "4 - 11". I want to separate first number nad change it to integer.
You_min_damage is integer.
Try this one:
Dim you_min_damage As Integer, you_max_damage As Integer
Dim arr
'store all values in array
arr = Split(Worksheets("charakters").Range("d14").Value, "-")
'get first value
you_min_damage = CInt(arr(0))
'get last value
you_max_damage = CInt(arr(UBound(arr)))
I'm trying to write a UDF (user-defined function) to create an average for non-numeric data (I'm converting it into numeric form then back again at the end). I can get the UDF to work if I list individual cells; I get a #VALUE! error if I try to refer to a range of cells. There may be a mix of both ranges and individual cells to process.
Any ideas?
The code so far is below.
Function avlvl(ParamArray av() As Variant)
Dim a As Integer
'creates an average ks3 level from data in format "5a"
a = 0
n = 0
total = 0
Do While a < UBound(av()) + 1
'ignore blank or zero cells
If av(a) = 0 Or av(a) = "" Then
a = a + 1
Else
'convert data into numeric value - split into level and sub level
level = Val(Left(av(a), 1))
sl = Right(av(a), 1)
If sl = "c" Then
sublevel = 0
ElseIf sl = "C" Then
sublevel = 0
ElseIf sl = "b" Or sl = "B" Then
sublevel = 1 / 3
ElseIf sl = "a" Or sl = "A" Then
sublevel = 2 / 3
Else
sublevel = 0
End If
'score is numeric value of the data
score = level + sublevel
'total is teh toatl of the cells so far
total = total + score
a = a + 1
n = n + 1
End If
Loop
ave = total / n
'reconvert into format level and sublevel (a,b,c)
averagelevel = Application.WorksheetFunction.RoundDown(ave, 0)
asl = ave - averagelevel
If asl < 0.17 Then
averagesublevel = "c"
ElseIf asl < 0.5 Then
averagesublevel = "b"
ElseIf asl < 0.84 Then
averagesublevel = "a"
ElseIf asl < 1 Then
averagelevel = averagelevel + 1
averagesublevel = "c"
Else
averagesublevel = "c"
End If
avlvl = averagelevel & averagesublevel
End Function
What's going on is that the range is coming in as a single object of type Range, and your code is trying to treat is as though it is coming in as an array.
The best approach would be to create a new array within the body of the function, and then assign the elements in the range to the new array. You need to test for the type of the elements of the ParamArray. If an element is type String, then put it directly in the new array; if an element is type Range, loop through it, assigning its cell values to the new array.
Then you would do your processing on the new array.
The following code provides the machinery to pass in ranges as well as individual cells or values. I've not included your code but have indicated where it would go.
Function avlvl(ParamArray av() As Variant) As Variant
Dim a As Integer
Dim i As Long
Dim avArr()
Dim element As Variant
a = 0
i = 0
Do While a < UBound(av) + 1
If TypeName(av(a)) = "String" Then
avArr(i) = av(a)
i = i + 1
ElseIf TypeName(av(a)) = "Range" Then
For Each element In av(a)
ReDim Preserve avArr(0 To i)
avArr(i) = element
i = i + 1
Next
Else
avlvl = CVErr(xlErrValue)
Exit Function
End If
a = a + 1
Loop
i = 0
Do While i < UBound(avArr) + 1
'...
'now process the elements of avArr()
'...
i = i + 1
Loop
End Function
If you have a disjoint range of cells and you want to pass them to a UDF, one approach is to create a Defined Name and pass it to the UDF as a single argument.