I have 20 cases. For every row in my sheet, I have a cell that assigns related case numbers to it. A row could have multiple case numbers assigned to it in that cell (Example: 1,2,11,12)
I am writing a code to copy all the rows that have Case number 1 assigned to them, copy them someplace else..
and then go to case number 2 and repeat the same..
This is what I am using:
For CaseNumbers = 1 To 20
For i = Row1 To RowLast
If InStr(1, Range(CaseNoCell & i).Value, CaseNumbers & ",") Then
COPY AND PASTE CODE
End If
Next
Next
The problem I am facing is, the code considers case number 11 as case number 1 too (since it has the digit 1).
This is the first time I am writing a VBA code and I have no background in this.
Can someone please advise on better way of doing this? Should I assign a checklist instead to each row?
All I want to do is find all the rows that have Case number 1 assigned, copy them.. then find all the rows that have Case 2 assigned, copy them.. and so on.
Please help.
You can use a function to do the test
Public Function isCaseNumberIncluded(ByVal caseToCheck As Long, ByVal caseNumbers As String) As Boolean
'add , to make all values distinct
caseNumbers = "," & caseNumbers & ","
Dim strCaseToCheck As String
strCaseToCheck = "," & caseToCheck & ","
If InStr(1, caseNumbers, strCaseToCheck) > 0 Then
isCaseNumberIncluded = True
End If
End Function
You would call this function within your main code like this:
Dim caseNumber As Long 'I removed the s - as this could be misleading in my eyes
For caseNumber = 1 To 20
For i = Row1 To RowLast
If isCaseNumberIncluded(caseNumber, Range(CaseNoCell & i).Value) Then
COPY AND PASTE CODE
End If
Next
Next
Using a separate function to run the test has two advantages:
your code gets more readable, ie you know from reading the functions name what the result should be - without reading the whole code how to do it :-)
you can re-use this code propably at another place
Or you can test the function first:
Public Sub test_isCaseNumberIncluded()
Debug.Print isCaseNumberIncluded(1, "1,2,11,12"), "Should be true"
Debug.Print isCaseNumberIncluded(1, "2,11,12"), "Should be false"
Debug.Print isCaseNumberIncluded(11, "1,2,11,12"), "Should be true"
Debug.Print isCaseNumberIncluded(11, "1,2,12"), "Should be false"
End Sub
Well, you are working with this piece of code:
If InStr(1, Range(CaseNoCell & i).Value, CaseNumbers & ",") Then
This checks against 1,, 12,, ..., but obviously it won't cover the last entry so that's something you'll need to add. And you have the problem that 11, gets treated as 1,.
In a similar way you can use this piece of code:
If InStr(1, Range(CaseNoCell & i).Value, "," & CaseNumbers & ",") Then
This checks against ,1,, ,12,, ... so it will solve your error, but obviously it won't cover the last and the first entry so that's something you'll need to add.
This is something that should be encapsulated in a function rather than being done in line. The method provided in VBA for tokenising a string is 'Split'.
You could wite a function that checks tokens 1 by 1, or which compile a collection of the tokens which then uses a built checking method of the collection to determine if the specified token is present or not.
In this specific case I've chosen to use the collection method. The specific object for the collection is the ArrayList (but a Scripting.Dictionary is also possible). The function contains checks for zero length strings and allows the seperator to be specified if it isn't a comma.
Option Explicit
Function FindToken(ByVal ipToken As String, ByVal ipTokenList As String, Optional ByVal ipSeparator As String = ",") As Boolean
' Guard against ipSeparator being vbnullstring
Dim mySeparator As String
mySeparator = IIf(VBA.Len(ipSeparator) = 0, ",", ipSeparator)
'Raise an error if ipToken or ipTokenList are empty strings
If VBA.Len(ipToken) = 0 Or VBA.Len(ipTokenList) = 0 Then
Err.Raise 17, "Empty string error"
End If
'Convert the token list to tokens
Dim myTokens As Variant
myTokens = VBA.Split(ipTokenList, mySeparator)
' Put the tokens in an ArrayList so we can use the contains method
' no point is doing early binding as arraylist doesn't provide intellisense
Dim myAL As Object
Set myAL = CreateObject("System.Collections.ArrayList")
Dim myItem As Variant
For Each myItem In myTokens
' Trim just in case there are spaces
myAL.Add VBA.Trim(myItem)
Next
'Finally test if the Token exists in the token list
Find = myAL.contains(VBA.Trim(ipToken))
End Function
This means that your code
If InStr(1, Range(CaseNoCell & i).Value, CaseNumbers & ",") Then
can now be rewritten as
If FindToken(CStr(CaseNUmbers), Range(CaseNoCell & cstr(i)).Value) Then
Identify Criteria Rows
Option Explicit
Sub Test()
Const WordSeparator As String = ","
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim CaseNumber As Long
Dim i As Long
Dim cValue As Variant
Dim cString() As String
For CaseNumber = 1 To 20
For i = Row1 To RowLast
cValue = CStr(ws.Range(CaseNoCell & i).Value)
If Len(cValue) > 0 Then
cString = Split(cValue, WordSeparator)
If IsNumeric(Application.Match( _
CStr(CaseNumber), cString, 0)) Then
' CopyAndPasteCode CaseNumber
Debug.Print "Case " & CaseNumber & ": " & "Row " & i
End If
End If
Next i
Next CaseNumber
End Sub
Related
I am having a problem with a particular line of code:
ActiveSheet.Range("A" & rowCount & ":" & Mid(alphabet, totHdrLngth, 1) & belowRowCount)
Where alphabet is a string containing uppercase letters A to Z.
I keep getting the following error:
Run-time error '5':
Invalid Procedure call or argument
I tried creating a String "inRange" and changing the code to this:
inRange = "A" & rowCount & ":" & Mid(alphabet, totHdrLngth, 1) & belowRowCount
curRange = ActiveSheet.Range(inRange)
But that did not help (as I thought it wouldn't). Any suggestions?
Although creating ranges like this is frowned upon in general, the way to do it is with the word SET (like #Gary McGill stated in the comments). Here is an example of how to do this:
Sub test()
Dim alphabet As String
Dim totHrdrLngth As Long
Dim belowRowCount As Long
Dim rowCount As Long
Dim inRange As Range
alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
totHrdrLngth = 5
belowRowCount = 10
rowCount = 5
' Gives us A5:E10
Set inRange = Range("A" & rowCount & ":" & range2 & _
Mid$(alphabet, totHrdrLngth, 1) & belowRowCount)
End Sub
You are running this macro in the current range, so there should be no need to specify ActiveSheet.Range. I hope this helps get you toward what you are trying to achieve.
As far as I can tell, you're getting an error because your types don't match up. I imagine rowCount is an integer, as is belowRowCount. If you convert them to strings before concatenating them, you can fix it. str() will convert an integer to a string with a space before it, and LTrim() will remove the space. Try code as below:
Dim sRowCount As String
Dim sBelowRowCount As String
and later
sRowCount = LTrim(Str(RowCount))
sBelowRowCount = LTrim(Str(belowRowCount))
inRange = "A" & sRowCount & ":" & Mid(alphabet, totHdrLngth, 1) & sBelowRowCount
curRange = ActiveSheet.Range(inRange)
Hope this helps.
I am working on a workbook in which I need to count how many times the "St/" substring is present in a Range (Column Q). Note: I am interested in all the occurrences, not just the number of cells in which the substring is present.
Here is the code I am trying to work with (based on the comment of Santhosh Divakar - https://stackoverflow.com/a/23357807/12536295), but I receive a runtime error (13) when running it. What am I missing / doing wrong?
Dim lastrow, q as Integer
lastrow = Range("A1").End(xlToRight).End(xlDown).Row
With Application
q = .SumProduct((Len(Range("Q1:Q" & lastrow)) - Len(.Substitute(Range("Q1:Q" & lastrow), "St/", ""))) / Len("St/"))
End With
See if the code below helps you:
Public Sub TestCount()
lastrow = Range("Q" & Rows.Count).End(xlUp).Row
strformula = "=SUMPRODUCT(LEN(Q1:Q" & lastrow & ")-LEN(SUBSTITUTE(UPPER(Q1:Q" & lastrow & "),""/ST"","""")))/LEN(""/St"")"
MsgBox Evaluate(strformula)
End Sub
I think you can count the number of characters, replace your "St/" with nothing and then count the characters again and divide by len("St/"). Here's an example.
'''your existing code
Dim lCount As Long
Dim lCount_After As Long
'''set a Range to column Q
Set oRng = Range("Q1:Q" & lRow_last)
'''turn that range into a string
sValues = CStr(Join(Application.Transpose(oRng.Value2)))
lCount = Len(sValues)
lCount_After = lCount - Len(Replace(sValues, "St/", ""))
lCount_After = lCount_After / 3
Debug.Print lCount_After
Using ArrayToText() function
a) If you dispose of Excel version MS365 you can shorten a prior string building by evaluating the tabular ARRAYTOTEXT()
formula to get a joined string of all rows at once (complementing #Foxfire 's valid solution).
Note that it's necessary to insert the range address as string;
in order to fully qualify the range reference I use an additional External:=True argument.
b) VBA's Split() function eventually allows to return the number of found delimiters (e.g. "St/") via
UBound() function. It returns the upper boundary (i.e. the largest available subscript) for this
zero-based 1-dimensional split array.
Example: If there exist eight St/ delimiters, the split array consists
of nine elements; as it is zero-based the first element has index 0
and the last element gets identified by 8 which is already the wanted function result.
Function CountOccurrencies(rng As Range, Optional delim as String = "St/")
'a) get a final string (avoiding to join cells per row)
Dim txt As String
txt = Evaluate("ArrayToText(" & rng.Address(False, False, External:=True) & ")")
'b) get number of delimiters
CountOccurrencies = UBound(Split(txt, delim))
End Function
Not the cleanest one, but you can take all into arrays and split by St/. Size of that array would be how many coincidences you got:
Sub test()
Dim LR As Long
Dim MyText() As String
Dim i As Long
Dim q As Long
LR = Range("Q" & Rows.Count).End(xlUp).Row
ReDim Preserve MyText(1 To LR) As String
For i = 1 To LR Step 1
MyText(i) = Range("Q" & i).Value
Next i
q = UBound(Split(Join(MyText, ""), "St/"))
Debug.Print q
Erase MyText
End Sub
The output i get is 8
Please, note this code is case sensitive.
The TextJoin() function in Excel 2019+ is used:
Sub CalcSt()
Const WHAT = "St/": Dim joined As String
joined = WorksheetFunction.TextJoin("|", True, Columns("Q"))
Debug.Print (Len(joined) - Len(Replace(joined, WHAT, ""))) / Len(WHAT)
End Sub
What I have here is a tracking list, for feeding pumps. We have to account for stock levels, so I made this. When you enter a pump, into the table, nothing happens. When you put a patient's name against it, the row goes pink to indicate the pump has left our stock.
I was trying to get a script/macro together that could count the pumps that we still had (i.e the white rows, e column), and display the list (table will get quite long in future) to the user.
My code:
It loops through the c column (serial numbers) for each "cll", an if statement checks if there is anything in the cell 2 columns to the right (patient name, if there is a patient name, it means the pump has been given out) AND if there is a value in the e column (serial numbers). It displays serial numbers that fulfill the criteria in a series of message boxes.
The code works, and I'm happy to roll it out, as this isn't an overly important issue, and I'll be leaving it with a group of technophobes. However, I'm wondering, it's a little clunky?
I don't like the seperate message boxes, but I can't find any info on making an array in excel VBA, and I don't like checking the IF using the offset property.
I couldn't make checking the cll.Interior.color/colorIndex work, as excel seemed to think the cells are all the same color, regardless of what color they actually are. (?conditional formatting causing issues).
Hope this makes sense,
EDIT:
Code as text:
Private Sub CommandButton1_Click()
Dim cll As Range
For Each cll In Range("c6:c200")
If IsEmpty(cll.Offset(0, 2)) And cll.Value > 0 Then
MsgBox "Pump Serial number: " & vbNewLine & vbNewLine & cll.Value
End If
Next cll
End Sub
concatenate the serial numbers in the loop and then after the loop show the concatenated string.
find the last cell with a value and only loop to that row.
Iterate a variant array instead of the range, it is quicker
Private Sub CommandButton1_Click()
Dim cll As Variant
cll = ActiveSheet.Range("C6", ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Offset(, 2)).Value
Dim str As String
str = ""
Dim delim As String
delim = ""
Dim i As Long
For i = 1 To UBound(cll, 1)
If Not IsEmpty(cll(i, 1)) And IsEmpty(cll(i, 3)) Then
str = str & delim & cll(i, 1)
If delim = "" Then delim = vbNewLine
End If
Next i
MsgBox "Pump Serial number: " & vbNewLine & vbNewLine & str
End Sub
I want to use the .find function in VBA to find instances of a value in a column, however there are calculations which are made based on criteria on the same rows as where the value is found. This is problematic because although the value I am looking for might be the same, the criteria which are used to create the overall score are different. As a result, I would need to loop through all the values which are found in the column and I was wondering how to do that in vba. I know the findnext function but I can never get it to work properly.
counted = Application.WorksheetFunction.CountIfs(cl.Range(finletter & "9:" & finletter & "317"), "Value", cl.Range("H9:H317"), wl.Range("A" & y.row).Value)
'Pol small low complex
If counted > 0 Then
MsgBox wl.Range("A" & y.row).Value
If cl.Range("C" & y.row).Value < 3 And cl.Range("D" & y.row).Value = 1 And cl.Range("E" & y.row).Value = "Interim" Then
wl.Range(y.Address) = 3.75 * counted
Here is an example. Say we are looking for the text "LOVE" in column A and process the data on those rows:
Option Base 1
Sub LookingForLove()
Dim s As String, rng As Range, WhichRows() As Long
Dim rFound As Range
ReDim WhichRows(1)
s = "LOVE"
Set rng = Range("A1:A25")
Set rFound = rng.Find(What:=s, After:=rng(1))
WhichRows(1) = rFound.Row
Do
Set rFound = rng.FindNext(After:=rFound)
If rFound.Row = WhichRows(1) Then Exit Do
ReDim Preserve WhichRows(UBound(WhichRows) + 1)
WhichRows(UBound(WhichRows)) = rFound.Row
Loop
msg = UBound(WhichRows) & vbCrLf & vbCrLf
For i = 1 To UBound(WhichRows)
msg = msg & WhichRows(i) & vbCrLf
Next i
MsgBox msg
End Sub
NOTE:
the Exit Do prevents looping forever
your code would continue by looping the elements of WhichRows() and processing the items on those rows.
your code could alternatively create a dynamic array of ranges or cell addresses.
Another alternative approach would be to use VBA to establish an AutoFilter and process the visible rows.
I am trying to get some text between two words from a column of similar data, so far I have:
Dim I As Integer
For I = 1 To 989
thisSTRING = Worksheets(1).Range("A" & I).Value
ref = Split(Split(thisSTRING, "RING ")(1), " EM")(0)
Worksheets(1).Range("B" & I).Value = ref
Next I
The problem I have is that not all text in the column is the same and when I reach such a point in the for loop I get an error message as there is either no "RING" or "EM", to avoid this I tried to use "on error resume next". This worked but it duplicates in the cells which had the errors. Is there any simple method for making this skip the cell/leave it blank instead of creating a duplicate?
Here's what I was thinking:
Sub PrintSplit()
Dim ws As Excel.Worksheet
Dim i As Long
Dim thisSTRING As String
Dim ref As String
Set ws = ThisWorkbook.Worksheets(1)
For i = 1 To 989
thisSTRING = ws.Range("A" & i).Value
If InStr(thisSTRING, "RING ") > 0 And InStr(thisSTRING, " EM") > 0 Then
ref = Split(Split(thisSTRING, "RING ")(1), " EM")(0)
ws.Range("B" & i).Value = ref
End If
Next i
End Sub
This assumes that you want a blank if either of the strings are missing. If you only wanted it if both strings are missing the logic would be different, but similar.
Note that I changed i to a Long which is a good practice, as it's the native type for whole numbers and will accommodate larger values. I also created a worksheet variable, just to make it a little more flexible, and to get Intellisense.