I am trying to write a module that makes a simple linear regression many times over many different data ranges. For this i am using a loop where i use the LinEst function inside INDEX function so that i can extract the slope and the intercept.
The problem i am having is that at the line 9 the program crashes sending me an
error(5): "Invalid argument or procedure call".
Edited: Corrections Made.
Now at line 11 it says:
error(1004): "can not read the LinEst property of the worksheet function class".
Update: it's working fine now i just deleted the word WorksheetFunction
Sub regression()
Dim i As Integer
Dim j As Integer
Dim range1 As Range
Dim range2 As Range
j = 139
i = 4
For i = 4 To 54 Step 1
Set range2 = Range(Sheets(1).Cells(22, j), Sheets(1).Cells(66, j))
Set range1 = Range(Sheets(1).Cells(22, j - 1), Sheets(1).Cells(66, j - 1))
Sheets(12).Cells(i, 2) = Application.WorksheetFunction.Index(Application.WorksheetFunction.LinEst(range1, range2), 1)
Sheets(12).Cells(i, 3) = Application.WorksheetFunction.Index(Application.WorksheetFunction.LinEst(range1, range2), 2)
j = j - 1
Next i
End Sub
You have the wrong syntax for the Range property.
If you want to refer to a range from Cells(22, j) to Cells(66, j), and both those cells are on Sheets(1), then instead of :
range2 = Sheets(1).Range(Cells(22, j), Cells(66, j))
you'd use:
range2 = Range(Sheets(1).Cells(22, j), Sheets(1).Cells(66, j))
or:
With Sheets(1)
range2 = Range(.Cells(22, j),.Cells(66, j))
End With
In this case the first loop would assign range2 an object representing $EI$22:$EI$66.
The following line has the same issue.
Related
For context of the code here. I have combined several of these 96 cell ranges into one larger range composed on n smaller ranges. Reason for doing this is to make it (more) scalable.
I have a range of data I want to break them up into n ranges/chunks and run my function on each (function below, shout out to #Tim Williams for the function) and combine the outputs all into a column. One solution I don't really like but I could do is to simply run the function on each n chunks/ranges and manually combine them, however, that's not really optimal for what I need. I am still pretty new to VBA, any ideas would be much appreciated!
The function I am using is as follows. Note my comment within the function:
Sub Tester()
Dim rng As Range, arr
Dim Poolws As Worksheet
Dim Combows As Worksheet
Dim plates As Range
Set Poolws = ThisWorkbook.Sheets("Pools")
Set Combows = ThisWorkbook.Sheets("Combined Plates")
Set rng = Combows.Range("C3:N66")
Set plates = Combows.Range("A2")
ArrayToCell BlockToList(rng, plates), Poolws.Range("A2") 'read by column
ArrayToCell BlockToList(rng, plates, False), Poolws.Range("F2") 'read by column
End Sub
'convert a rectangular range into a 2-d single-column array
' Read by row(default) or by column (pass False as second argument)
Function BlockToList(rng As Range, plates As Range, Optional rowMajor As Boolean = True)
Dim m As Long, n As Long, dr, dc, arrData, arrOut, platenum, i As Long
arrData = rng.Value
platenum = plates.Value
dr = UBound(arrData, 1)
dc = UBound(arrData, 2)
ReDim arrOut(1 To (dr * dc), 1 To 1)
If rowMajor Then
For m = 1 To dr
For n = 1 To dc
i = i + 1
arrOut(i, 1) = arrData(m, n)
Next n
Next m
Else
For m = 1 To dc
' I think something in the following lines needs to change.
' divide array by plantenum into that many arrays then on each
' run the following, pasting the results sequentially in a column
For n = 1 To dr / platenum
i = i + 1
arrOut(i, 1) = arrData(n, m)
Next n
Next m
End If
BlockToList = arrOut
End Function
'Utility method for populating an array to a range
Sub ArrayToCell(arr, rngDest As Range)
rngDest.Cells(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub
Here's how I'd approach that:
Sub Tester()
Const PLT_ROWS As Long = 8
Const PLT_COLS As Long = 12
Dim rng As Range, arr, rngOut As Range
Dim Poolws As Worksheet
Dim Combows As Worksheet
Dim plates As Range
Set Poolws = ThisWorkbook.Sheets("Pools")
Set Combows = ThisWorkbook.Sheets("Combined Plates")
Set rng = Combows.Range("C3").Resize(PLT_ROWS, PLT_COLS)
Set rngOut = Poolws.Range("F2")
Do While Application.CountA(rng) > 0
ArrayToCell BlockToList(rng, False), rngOut 'by column or by row?
Set rng = rng.Offset(rng.Rows.Count, 0) 'next input block
Set rngOut = rngOut.Offset(0, 1) 'output next column over?
'Set rngOut = rngOut.Offset(rng.Cells.Count, 0) '...or append to previous?
Loop
End Sub
Rest of code from previous question is unchanged - in order to keep your code as modular as possible it's best to avoid special-casing your "core" methods where you can.
If you're dealing with multi-plate output files from an instrument, ideally you want to be reading directly from those files (typically after opening them in Excel so you don't need to do the parsing) with no intermediate copy/paste/consolidate steps.
I found a solution (for anyone who cares):
I added a loop that breaks the range/array/chunk into sections (in this case I know they are always 8 "tall"). I'm sure someone could have a better solution, but this one worked for me! Code as follows:
'convert a rectangular range into a 2-d single-column array
' Read by row(default) or by column (pass False as second argument)
Function BlockToList(rng As Range, plates As Range, Optional rowMajor As Boolean = True)
Dim m As Long, n As Long, o As Long, dr, dc, arrData, arrOut, platenum, i As Long
arrData = rng.Value
platenum = plates.Value
dr = UBound(arrData, 1)
dc = UBound(arrData, 2)
ReDim arrOut(1 To (dr * dc), 1 To 1)
If rowMajor Then
For m = 1 To dr
For n = 1 To dc
i = i + 1
arrOut(i, 1) = arrData(m, n)
Next n
Next m
Else
For o = 0 To platenum * 8
If ((o * 8) + 8) <= dr Then
For m = 1 To dc
' divide array by plantenum into that many arrays then on each
' run the following, pasting the results sequentially in a column
For n = ((o * 8) + 1) To ((o * 8) + 8)
i = i + 1
arrOut(i, 1) = arrData(n, m)
Next n
Next m
End If
Next o
End If
BlockToList = arrOut
End Function
I have 'for i = 1 to x' loop to fill columns however it is very slow.
I don't have enough knowledge of vba to know a different way.
Here is my code:
Dim j As Long
j = 6
For i = 4 To EFlast_row
If InStr(ef.Cells(i, ActualTitleColumn).Value, search.Cells(searchboxrow, searchboxcolumn).Value)Then
search.Cells(j, SearchLayerColumn).Value = ef.Cells(i, layercolumn).Value
j = j + 1
End If
Next i
Any help would be much appreciated.
Thank you
This code will put the data from sheets into a range variable. Comparisons using range variables are significantly quicker than using a reference like:
Sheets("Sheet1").Cells(1,1).Value
You will need to update this to reflect the variables you are using.
Function search()
' Put data on sheets into ranges
Dim rangeOne As Range, rangeTwo As Range
Set rangeOne = Sheets("Sheet1").UsedRange
Set rangeTwo = Sheets("Sheet2").UsedRange
' Iterands for rangeOne and rangeTwo respectively
Dim i As Long, j As Long
For i = 2 To rangeOne.Rows.Count
For j = 2 To rangeTwo.Rows.Count
If InStr(rangeOne(i, 1).Value2, rangeTwo(j, 1).Value2) Then
rangeTwo(j, 2).Value2 = rangeOne(i, 2).Value2
End If
Next j
Next i
End Function
I'm setting up a subroutine to perform matches between two worksheets. The arrays are one dimensional going from the first cell of data to the last, which is held within a variable.
The data in the arrays are not numerical, but if I ReDim them as strings I get a type mismatch in the initialization.
SheetOneLastRow and SheetTwoLastRow are subroutines which find the last row in each sheet to be held in the variables FirstLastRow and SecondLastRow which are declared globally because they are used in other subs.
EDIT 1: The error is on the line:
If search(i) = arr(j) Then
Value of FirstLastRow is 9589 and SecondLastRow is 20750.
The search and arr have only been declared here with ReDim.
Sub Match()
SheetOneLastRow
SheetTwoLastRow
Dim i, j As Integer
ReDim arr(SecondLastRow - 2) As Variant
ReDim search(FirstLastRow - 2) As Variant
search = Range(wksv.Cells(2, 11), wksv.Cells(FirstLastRow, 11))
arr = Range(wkst.Cells(2, 6), wkst.Cells(SecondLastRow, 6))
For i = 2 To FirstLastRow
For j = 2 To SecondLastRow
If search(i-2) = arr(j-2) Then
wkst.Cells(j, 3) = wksv.Cells(i, 3)
End If
Next j
Next i
End Sub
Search() is a 2D array, and the code is using it as a 1D array.
In general, passing range to arrays is not complicated, but there are a few tricks, you should be aware of. First trick - whenever the range is passed like this:
search = Range(wksv.Cells(2, 11), wksv.Cells(FirstLastRow, 11)) it is passed to a 2-dimensional array. See the blue highlighted line at the screenshot:
The problem with the 2-dimensional arrays is that they are of two dimensions. E.g., you should be looking for Search(2,1) instead of Search(2). Or in the code above it should be: If Search(i,1) = arr(j,1) Then
There are probably better ways to solve the problem, e.g. passing the range to a single dimensional array, as in the example here - https://stackoverflow.com/a/52467171/5448626
This is what would happen, if you force the range to be a 1D array:
Sub Match()
Dim i, j As Integer
FirstLastRow = 9589
SecondLastRow = 20750
ReDim arr(SecondLastRow - 2) As Variant
ReDim Search(FirstLastRow - 2) As Variant
With Worksheets(1) 'put wksv
Search = Application.Transpose(.Range(.Cells(2, 11), .Cells(FirstLastRow, 11)))
End With
With Worksheets(2) 'put wkst
arr = Application.Transpose(.Range(.Cells(2, 6), .Cells(SecondLastRow, 6)))
End With
For i = 2 To FirstLastRow - 2 '-2 is needed because of ReDim arr(SecondLastRow - 2)
For j = 2 To SecondLastRow - 2
If Search(i) = arr(j) Then
Worksheets(1).Cells(j, 3) = Worksheets(2).Cells(i, 3)
End If
Next j
Next i
End Sub
I have this code to find the values that belong to the value in cell C3 (and further down):
aantalrijen = .Range("A2", .Range("A2").End(xlDown)).Cells.Count
For I = 2 To aantalrijen + 1
For J = 108 To 112
For Each cell In .Range(.Cells(2, J), .Cells(aantalrijen, J)).Cells
cell.Value = Application.VLookup(.Cells(I, 3), Sheets("omzet").Range("C:DH"), J - 2, 0)
Next cell
Next J
Next I
I am aware this cannot be the most efficient way to get the desired result. How should I adjust the code to make it the most efficient?
Update:
For now I am satisfied with this result:
aantalrijen = .Range("A2", .Range("A2").End(xlDown)).Cells.Count
For J = 108 To 112
For I = 2 To aantalrijen
.Cells(I, J).Value = Application.VLookup(.Cells(I, 3), Sheets("omzet").Range("C:DH"), J - 2, 0)
Next I
Next J
End With
it is fast enough for me now and it returns the desired results.
Here:
Option Explicit
Sub Test()
Dim arrSource, arrData, i As Long, j As Long, ColI As Long, ColF As Long
Dim DictMatches As New Scripting.Dictionary
Dim DictHeaders As New Scripting.Dictionary
With ThisWorkbook
arrSource = .Sheets("omzet").UsedRange.Value
arrData = .Sheets("SheetName").UsedRange.Value 'change this for the worksheet you are working on
End With
For i = 1 To UBound(arrSource, 2) 'this will store the headers position
DictHeaders.Add arrSource(1, i) 'this will throw an error if you have any duplicate headers
Next i
For i = 2 To UBound(arrSource) 'this will store the row position for each match
DictMatches.Add arrSource(i, 3), i 'this will throw an error if you have any duplicates
Next i
'Here you can change where you want to evaluate your data
ColI = 108
ColF = 112
For i = 2 To UBound(arrData) 'loop through rows
For j = ColI To ColF 'loop through columns
arrData(i, j) = arrSource(DictMatches(arrData(i, 3), DictHeaders(1, j)))
Next j
Next i
'Paste the arrData back to the sheet
ThisWorkbook.Sheets("SheetName").UsedRange.Value = arrData
End Sub
This is the fastest way, why?
You store both sheets into the arrays and from then on you work only with the arrays(which means working on memory, so working faster)
Using excel functions always slow downs the process, instead we are storing all the index values on rows and headers for the omzet sheet, so when you point to a value from Column C on your working sheet, it gives you the result without calculating anything.
Here: arrSource(DictMatches(arrData(i, 3), DictHeaders(1, j))) we are giving a row position and column position.
DictMatches(arrData(i, 3) will give you back the row where that match was found inside the dicitonary. DictHeaders(1, j) will give you back the column where that header was found inside the dictionary.
Note: for dictionaries to work you need the Microsoft Scripting Runtime library checked on your references. Also Dictionaries are Case Sensitiveso Hello <> hello.
I am attempting to run a VBA macro that iterates down about 67,000 rows with 100 columns in each row. For each of the cells in these rows, the value is compared against a column with 87 entries in another sheet. There are no errors noted when the code is run but Excel crashes every time. The odd thing is that the code seems to work; I have it set to mark each row in which a match is found and it does so before crashing. I have attempted to run it many times and it has gotten through between 800 and 11,000 rows before crashing, depending on the attempt.
My first suspect was memory overflow due to the volume of calculations but my system shows CPU utilization at 100% and memory usage around 50% while running this code:
Sub Verify()
Dim codes As String
Dim field As Object
For i = 2 To Sheets("DSaudit").Rows.Count
For Each field In Sheets("Dsaudit").Range(Cells(i, 12), Cells(i, 111))
r = 1
While r <= 87
codes = ThisWorkbook.Sheets("287 Denominator CPT").Cells(r, 1).Value
If field = codes Then
Cells(i, 112).Value = "True"
r = 88
Else
r = r + 1
End If
Wend
Next field
i = i + 1
Next i
End Sub
It should also be noted that I am still very new to VBA so it's likely I've made some sort of egregious rookie mistake. Can I make some alterations to this code to avoid a crash or should I scrap it and take a more efficient approach?
When ever possible iterate variant arrays. This limits the number of times vba needs to access the worksheet.
Every time the veil between vba and Excel is pierced cost time. This only pierces that veil 3 times not 9,031,385,088
Sub Verify()
With Sheets("DSaudit")
'Get last row of Data
Dim lastrow As Long
lastrow = .Cells(.Rows.Count, 12).End(xlUp).Row 'if column 12 ends before the last row of data change to column that has them all.
'Load Array with input Values
Dim rng As Variant
rng = .Range(.Cells(2, 12), .Cells(lastrow, 111)).Value
'Create output array
Dim outpt As Variant
ReDim outpt(1 To UBound(rng, 1), 1 To 1)
'Create Match array
Dim mtch As Variant
mtch = Worksheets("287 Denominator CPT").Range("A1:A87").Value
'Loop through first dimension(Row)
Dim i As Long
For i = LBound(rng, 1) To UBound(rng, 1)
'Loop second dimension(Column)
Dim j As Long
For j = LBound(rng, 2) To UBound(rng, 2)
'Loop Match array
Dim k As Long
For k = LBound(mtch, 1) To UBound(mtch, 1)
'If eqaul set value in output and exit the inner loop
If mtch(k, 1) = rng(i, j) Then
outpt(i, 1) = "True"
Exit For
End If
Next k
'If filled true then exit this for
If outpt(i, 1) = "True" Then Exit For
Next j
Next i
'Assign the values to the cells.
.Cells(2, 112).Resize(UBound(outpt, 1), 1).Value = outpt
End With
End Sub