I have a function that loops through X sheets to count how many meet a certain criteria, but I want this criteria to be variable.
This is my code for the function:
Function f_1(Condition As Variant, Condition_TrueFalse As Boolean, i_Start As Long, i_End As Long) As Long
f_1 = 0
For i = i_Start To i_End
Select Case Condition
Case Condition_TrueFalse
f_1 = Application.Sum(f_1, 1)
End Select
Next i
End Function
I have a workbook with 20 worksheets, with the names "WorksheetNumber1", "WorksheetNumber2", "WorksheetNumber3", "WorksheetNumber4", ..., "WorksheetNumber20".
So, for example, I might have this subroutine:
Sub(Workbook1 As Workbook)
Dim count As Long
'example A
count = f_1(IsEmpty(Workbook1.Worksheets("WorksheetNumber" & i).Cell(1,1)),False,1,10)
MsgBox(count)
'example B
count = f_1(Application.CountA(Workbook1.Worksheets("WorksheetNumber" & i).Range("$C$3:$E$5"))>0,True,1,5)
MsgBox(count)
End Sub
I have multiple of these criteria, so I really don't want to repeat the code; since the structure of the code is similar, I thought I might be able to make the criteria variable.
What I want is:
For Example A, if cell(1,1) is not empty for WorksheetNumberi (for i = 1 To 10), then f_1 goes up by one; the final value for f_1 is returned and assigned to the variable 'count'; and then 'count' is displayed.
For Example B, if the count of non-empty cells in range $C$3:$E$5 is greater than 0 for WorksheetNumberi (for i = 1 To 5), then the f_1 goes up by one; the final value for f_1 is returned and assigned to the variable 'count'; and then 'count' is displayed.
Currently, I'm running into a "Subscript Out of Range" error, in the "count = ..." lines of code, which I'm guessing is because of the 'i' in Worksheets("SheetNumber" & i). How might I go about coding to achieve the results I want?
Thank you so much!
Provided all of your tests can be expressed as worksheet formulas then you can do something like this:
Sub tester()
Debug.Print CountIt(ThisWorkbook, "A1<>""""", 1, 5)
Debug.Print CountIt(ThisWorkbook, "COUNTA(C3:E5)>0", 1, 5)
Debug.Print CountIt(ThisWorkbook, "CountRedFont(B3:B5)", 1, 5)
End Sub
Function CountIt(wb As Workbook, theTest As String, _
fromSheet As Long, toSheet As Long) As Long
Dim n As Long, i As Long
For i = fromSheet To toSheet
n = n + IIf(wb.Sheets(i).Evaluate(theTest), 1, 0)
Next i
CountIt = n
End Function
'test UDF
Function CountRedFont(rng As Range)
Dim c As Range, n As Long
For Each c In rng.Cells
If c.Font.Color = vbRed Then n = n + 1
Next c
CountRedFont = n
End Function
Related
example2 example1 The file name I'm trying to match is on Row A and I'm looking through Row I to see if there is a match I found this code I can't recall where but I am trying to match row of part numbers to a row of its image file names. This code works, however, there is a problem when I run it it takes really long to calculate even just 1 column and when I do hundreds at a time my excel just stops responding, and I have thousands of products I need to match. I am really new with VBA so I can't even figure out the problem.
Please help, thank you.
'Name function and arguments
Function SearchChars(lookup_value As String, tbl_array As Range) As String
'Declare variables and types
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
'Iterste through each cell
For Each cell In tbl_array
'Save cell value to variable
str = cell
'Iterate through characters
For i = 1 To Len(lookup_value)
'Same character?
If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
'Add 1 to number in array
a = a + 1
'Remove evaluated character from cell and contine with remaning characters
cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) & Mid(cell, InStr(cell, Mid(lookup_value, i, 1)) + 1, 9999)
End If
'Next character
Next i
a = a - Len(cell)
'Save value if there are more matching characters than before
If a > b Then
b = a
Value = str
End If
a = 0
Next cell
'Return value with the most matching characters
SearchChars = Value
End Function
EDIT (post seeing the data): The following should be notably faster (as well as notably simpler)
'Name function and arguments
Function SearchChars(lookup_value As String, tbl_array As Range) As String
'Declare variables and types
Dim inLenMatched%, vnVal, varLookupValues()
'Puts lookup cell values into a array (to speed things up)
varLookupValues = tbl_array.Value
'Iterate through each lookup value
For Each vnVal In varLookupValues
'Ignore empty cells
If vnVal <> "" Then
'Does part number appear in filename?
If InStr(lookup_value, vnVal) > 0 Then
'Is this match the most complete match so far?
If Len(vnVal) > inLenMatched Then
inLenMatched = Len(vnVal)
SearchChars = vnVal
End If
End If
End If
Next vnVal
'Return match value (or 'No Match' if not matched)
If SearchChars = "" Then SearchChars = "No Match"
End Function
The above is just one off-the-cuff approach.
There are other (and quite possible faster) ways to approach this.
The most obvious step (regardless of method) to improving performance would be to limit tbl_array to only the rows with data (not the entire column).
Separately: Without knowing all possible cases, it's impossible to say for sure. But, in all probability, this can be done with Native excel functions, and (if so) that will deliver the best performance.
As said, minimizing the interactions with the sheet by assigning the range to an array will structurally make your macros faster.
Not tested but these minor changes in your code should help you on the right track:
Option Explicit
'Name function and arguments
Function SearchChars2(lookup_value As String, tbl_array As Range) As String
'Declare variables and types
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
'Iterste through each cell => replace with array
'adapt to correct sheet
Dim arr
arr = tbl_array
For Each cell In arr 'tbl_array
'Save cell value to variable
str = cell
'Iterate through characters
For i = 1 To Len(lookup_value)
'Same character?
If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
'Add 1 to number in array
a = a + 1
'Remove evaluated character from cell and contine with remaning characters
cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) & Mid(cell, InStr(cell, Mid(lookup_value, i, 1)) + 1, 9999)
End If
'Next character
Next i
a = a - Len(cell)
'Save value if there are more matching characters than before
If a > b Then
b = a
Value = str
End If
a = 0
Next cell
'Return value with the most matching characters
SearchChars2 = Value
End Function
I was trying to modify your existing code, but I found it easier to just rewrite it using what I consider to be a better structure. And After running the code over 26 columns & 432 rows, It only took 0.2 seconds to find the Closest Matching String.
I moved every value into an array.
I converted the lookup_value and the "cell values" into an array of bytes.
I compared the byte arrays to count matching "characters".
And then I return the string that had the highest number of matching "characters".
Sub Example()
Dim StartTime As Double
StartTime = Timer * 1000
Debug.Print SearchChars3("Toddleson", Range("A1:Z432"))
Debug.Print "Time Elapsed: " & Timer * 1000 - StartTime & " ms"
'Time Elapsed: 171.875 ms
End Sub
Function SearchChars3(lookup_value As String, tbl_array As Range) As String
Dim ClosestMatch As String, HighestMatchCount As Integer
Dim tbl_values() As Variant
tbl_values = tbl_array.Value
Dim LkUpVal_Bytes() As Byte
LkUpVal_Bytes = ToBytes(lookup_value)
Dim Val As Variant
For Each Val In tbl_values
If Val = "" Then GoTo nextVal
Dim Val_Bytes() As Byte
Val_Bytes = ToBytes(CStr(Val))
Dim MatchCount As Integer
MatchCount = CountMatchingElements(LkUpVal_Bytes, Val_Bytes)
If MatchCount > HighestMatchCount Then
HighestMatchCount = MatchCount
ClosestMatch = Val
End If
nextVal:
Next
SearchChars3 = ClosestMatch
End Function
Function ToBytes(InputStr As String) As Byte()
Dim ByteArr() As Byte
ReDim ByteArr(Len(InputStr) - 1)
Dim i As Long
For i = 0 To Len(InputStr) - 1
ByteArr(i) = AscW(Mid(InputStr, i + 1, 1))
Next
ToBytes = ByteArr
End Function
Function CountMatchingElements(Arr1 As Variant, Arr2 As Variant) As Integer
'As elements from Arr1 are found in Arr2, those elements are removed from Arr2, to prevent re-matching with the same elements
'To enable this feature, Arr2 is turned into a Collection
Dim Col2 As New Collection
Dim v As Variant
For Each v In Arr2
Col2.Add v
Next
Dim MatchCount As Integer, i As Long
For Each v In Arr1
For i = 1 To Col2.Count
If Col2.Item(i) = v Then
MatchCount = MatchCount + 1
Col2.Remove (i)
Exit For
End If
Next
Next
CountMatchingElements = MatchCount
End Function
A further optimization could be to have a second version of the ToBytes function that directly outputs the values into a Collection. Then, you can change CountMatchingElements to accept a collection and it wont need to convert the second array into a collection.
I will leave that as an idea for you to experiment with.
Function test()
Dim result As String
Dim x As Integer
Dim search_value As String
Dim column As Integer
search_value = "esg001"
column = 1
For x = 2 To 3
Sheets(x).Select
Range("B:B").Select
On Error Resume Next
Cells.Find(search_value).Select
ActiveCell.Offset(0, column).Select
result = ActiveCell.Value
If search_value <> "" Then
GoTo ola
Else
End If
Next
ola:
test = result
End Function
as stated in the comments the following formula will do what you want:
=IFERROR(VLOOKUP("esg001",Sheet2!B:C,2,FALSE),VLOOKUP("esg001",Sheet3!B:C,2,FALSE))
Where Sheet2 and Sheet3 are the names of the sheets.
Now a couple of notes on your attempted code.
Do not use .Select. More info on that HERE
when using UDF avoid hardcoding ranges, pass them as parameters. The reason is that the formula would not update when the data updates if it is not a parameter.
This accepts two parameters: Search Value and which column to return. It also accepts as many ranges as desired to search for the value:
Function test(schVal As String, clm As Long, ParamArray schRng() As Variant) As Variant
Dim i As Long
For i = LBound(schRng) To UBound(schRng)
If TypeOf schRng(i) Is Range Then
If schRng(i).Columns.Count > clm Then Exit Function
Dim rngArr() As Variant
rngArr = Intersect(schRng(i), schRng(i).Parent.UsedRange).Value
Dim j As Long
For j = 1 To UBound(rngArr, 1)
If rngArr(j, 1) = schVal Then
test = rngArr(j, clm)
Exit Function
End If
Next j
Else
test = "Parameters 3 and higher should be ranges"
Exit Function
End If
Next i
test = "Not Found"
End Function
Now you would call it (using the formula above as a template):
=TEST("esg001",2,Sheet2!B:C,Sheet3!B:C)
It will first
The following code is not working. I get a 2042 error for my VLOOKUP function, however whatever I do I cannot solve it. I have been using if ISERROR and it still does not catch it properly compromising my whole macro. If I run a local window you can see that the value to search for being stored in array "arr" if not found in the "target" range return a 2042 even for subsequent entries.
Sub test()
ThisWorkbook.Activate
Worksheets.add
Worksheets("Test4").Range("A1:T110").copy Destination:=ActiveSheet.Range("A1")
With ActiveSheet
Dim Search_Array As Variant
Search_Array = Range("C2", Range("C1").End(xlDown)) 'use this array to loop through the value to search for
Dim Target_MatchValue As Integer
Dim Target_Range As Range
Dim arr As Variant
Dim counter As Integer
Dim n As Integer
counter = 0
n = 0
Target_MatchValue = 0
For counter = LBound(Search_Array) To UBound(Search_Array)
Target_MatchValue = 0
Target_MatchValue = Application.Match(Search_Array(counter, 1), .Range("H2:H200"), 0) - 1
Set Target_Range = .Range(.Cells(2 + n, 8), .Cells(1000, 9))
arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False)
If IsError(arr) Then
.Range(Cells(1 + counter, 6), Cells(1 + counter, 6)).value = "N/A"
Else
.Range(Cells(1 + counter, 6), Cells(1 + counter, 6)).value = arr 'Return the value of the array in this cell
End If
Target_Range.Select
If Target_MatchValue = 0 Then
n = n + 1
ElseIf Target_MatchValue > 0 Then
n = n + Target_MatchValue
End If
Next counter
End With
End Sub
SOLUTION
Sub test()
Dim Search_Array As Variant
Dim Target_MatchValue As Variant
Dim Target_Range As Range
Dim arr As Variant
Dim counter As Integer
Dim n As Integer
Worksheets("Test4").Range("A1:T110").copy Destination:=ActiveSheet.Range("A1")
With ActiveSheet
'data must be ordered in order to apply the non-repetitive condition
Search_Array = Sheet1.Range("A2", Sheet1.Range("A1").End(xlDown)) 'use this array to loop through the value to search for
n = 0
With ActiveSheet
For counter = LBound(Search_Array) To UBound(Search_Array)
Target_MatchValue = 0
Target_MatchValue = Application.Match(Search_Array(counter, 1), .Range(Cells(2 + n, 4), Cells(1000, 4)), 0) 'The problem was here. "A1:T110" did not allowed to the shifting range to change. Now this code will return the value used for the shifting range
Set Target_Range = .Range(Cells(2 + n, 4), Cells(1000, 5)) 'this is supposed to work as a shifting range allowing to match entries without making repetitions. I used the MATCH function in order to set the start of the range. i.e. if there is a match in the target table the range will shift from the location of the match downwards. If the match is at on the same level then it does not shift the range in order to match the same-level entry afterwards it is supposed to shift by one unit in order to prevent repetitions.
'target_range.select Activate this code in order to see the macro in action
arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False) 'store the vlookup value in an array in order to increase the efficiency the code and to speed up the whole proces
If IsError(arr) Then
.Cells(2 + n, 2).value = "" 'if the macro does not find anything, no value will be recorded anywhere
Else
.Cells(1 + n + Target_MatchValue, 2).value = Search_Array(counter, 2) 'Return the value of the search_array in this cell so to match column A values with column D values if they are found
End If
If IsError(arr) Then
n = n
ElseIf Target_MatchValue = 0 Then 'if the macro does not find anything, the shifting range does not shift so that subsequent values can be searched in the same range without missing precious matches
n = n + 1
ElseIf Target_MatchValue > 0 Then 'if there is a matching value between Column A and Column B, the shifting range shifts by the n + the distance between the the current vlookupvalue and the found value. Note that Data must be stored in a filtered order otherwise vlookup will not work correctly
n = n + Target_MatchValue
End If
Next counter
End With
End Sub
Declare your Target_MatchValue As Variant so no errors will be raised, instead you will have to handle what do you want to do when IsError(Target_MatchValue) (when no matches are found)
I'm VERY new to Excel VBA. I want to write a function that offsets the cells in the current vector (the range selected by the user) by an amount also specified by the user.
The cells must be moved up out of the array by "n", and must then be displayed at the bottom of the same array after the remaining cells have moved up to take the place of the cells shifted up and out of the array.
Any advice will be greatly appreciated, the current code I wrote is not working and I know too little to help myself.
Many thanks!
Function ShiftVector(rng As Range, n As Integer)
'User selects a vector and inputs an integer.
'The vector must be sorted upwards by the amount equal to the entered integer
Dim i As Integer, rw As Integer, temp As Variant
rw = rng.rows.Count
ReDim b(1 To rw) As Variant
ReDim temp(1 To n) As Variant
b = rng
For i = 1 To n
temp = b(i)
'move the data in cells i=1 to n to the temporary array
Next i
b(i) = rng.Offset(-n, 0)
'move the cells in array b up by n
For i = rw - n To nr
b(i) = temp
i = i + 1
'I'm not sure if this is correct: I want to replace the top shifted cells
'back into the bottom of array b
Next i
ShiftVector4 = b
'The function must output the newly assembled array b where
'the top cells that were moved up n-spaces are now wrapped
'around and are shown at the bottom of the array b
End Function
Something like this should work:
Sub Tester()
ShiftUp Range("B4:C13"), 3
End Sub
Sub ShiftUp(rng As Range, numRows As Long)
Dim tmp
With rng
tmp = .Rows(1).Resize(numRows).Value
.Rows(1).Resize(.Rows.Count - numRows).Value = _
.Rows(numRows + 1).Resize(.Rows.Count - numRows).Value
.Rows((.Rows.Count - numRows) + 1).Resize(numRows).Value = tmp
End With
End Sub
As a UDF:
Function ShiftUp(rng As Range, numRows As Long)
Dim d, dOut, r As Long, c As Long, rMod As Long, rTot As Long
Dim break As Long
d = rng.Value
dOut = rng.Value 'as a shortcut to creating an empty array....
rTot = UBound(d, 1)
break = rTot - numRows
For r = 1 To rTot
For c = 1 To UBound(d, 2)
'figure out which input row to use...
rMod = IIf(r <= break, r + numRows, -(break - r))
dOut(r, c) = d(rMod, c)
Next c
Next r
ShiftUp = dOut
End Function
Note this is an array formula, so you will need to select a range the same size as the input range and enter the formula using CtrlShiftEnter
I don't have much experience but I'm trying to write a function that will search column A and the 1st time it finds a string beginning with "AT" it will copy that whole string to Cell N1, the 2nd string beginning with "AT" will be copied to N2, so on and so forth until column A is exhausted. This is my feeble attempt so far but I'm not having much luck.
Function Find_AT(ByVal I As Integer)
Dim c As Range
Dim COUNTER As Integer
Dim CAPTURE As Long
COUNTER = 0
For Each c In Range("A1", Range("A65636").End(xlUp))
If Left(c, 2) = AT Then
COUNTER = COUNTER + 1
If COUNTER = I Then
CAPTURE = c
Exit For
End If
End If
Next c
Find_AT = CAPTURE
End Function
Consider:
Function Find_AT(ByVal I As Long) As String
Dim c As Range
Dim COUNTER As Long
Dim CAPTURE As String
Dim v As String
COUNTER = 0
CAPTURE = "xx"
For Each c In Range("A1", Range("A65636").End(xlUp))
v = c.Text & " "
If Left(v, 2) = "AT" Then
COUNTER = COUNTER + 1
If COUNTER = I Then
CAPTURE = c.Address
Exit For
End If
End If
Next c
Find_AT = CAPTURE
End Function
The error with your code is that the text (the string) AT needs to be enclosed in double-quotes "AT". Add Option Explicit to the top of the Module and it would take you to this error when you try to compile or execute the function.
However, given your description, I suspect that you might want to write a sub-procedure (SUB) not a Function. A function is intended to return a value. If you want to use a function you might define it like this:
Function Find_AT(rng As Range, ByVal i As Integer)
That is, you would supply it a Range to search and the number 1 to find the first value in the range that begins with "AT". However, if you put this function in a cell and copy it down, it will still return only the first occurrence. You would need to manually change 1 to 2, 3, etc. (or use a variation of ROW() to automatically generate this sequence).
Anyway, I suspect you really want a SUB-procedure that you might run by clicking a button on the worksheet.
If you wish to continue with your current function, then you could declare the return type as a string:
Function Find_AT(ByVal i As Integer) As String
'...
Dim CAPTURE As String
'...
CAPTURE = c.Text
Otherwise, setting CAPTURE = c and attempting to return this value causes a problem because c is a Range object.
Filtering is much more efficient. Two approaches below:
Filter
Sub GetAT1()
X = Filter(Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp))), "AT", True)
If UBound(X) > 0 Then [n1].Resize(UBound(X) + 1) = Application.Transpose(X)
End Sub
AutoFilter
Sub GetAT()
Dim rng1 As Range
Set rng1 = Range([a1], Cells(Rows.Count, "A").End(xlUp))
Application.ScreenUpdating = False
ActiveSheet.AutoFilterMode = False
rng1.AutoFilter 1, "=AT*"
rng1.Copy [n1]
If LCase$(Left$([n1], 2)) <> "at" Then [n1].Delete xlUp
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub