I am new to VBA Excel programming. Consider an Excel sheet with nxn values. My task is to search for text called "TOOTHBRUSH BATT" from A column. A column consists of multiple "TOOTHBRUSH " value.
Once the value is found suppose in cell A11 then I need to change text in D11 ie corresponding D column to "BATTERY". D11 will already have some text, I need to replace that text with "BATTERY"
My code is
Sub replacement()
Dim S As String
Dim H As String
S = "TOOTHBRUSH BATT"
For i = 1 To Range("A1").End(xlDown).Row
If Range("A" & i) = S Then
Range("D" & i) = "BATTERY"
End If
Next i
End Sub
nRow = Worksheets(1).Range("A:A").Find(What:="*TOOTHBRUSH BATT*", after:=Range("A1"), LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Row
Worksheets(1).Cells(nRow,"D") = "BATTERY"
By using auto filter (below code not tested)
Worksheets(1).autofiltermode = false
Worksheets(1).Range("A:B").autofilter
Worksheets(1).AutoFilter.Range.AutoFilter Field:=1, Criteria1:="*TOOTHBRUSH BATT*"
dim nRng as range
If Worksheets(1).AutoFilter.Range.Offset(1,0).Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
set nRng = Worksheets(1).AutoFilter.Range.Offset(1,0).Columns(2).Resize(Worksheets(1).AutoFilter.Range.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
nRng.value = "BATTERY"
End If
This is Similar to Eric's Answer.
' Declare range to set to the first cell we find
Dim find as Range
set find = Range("A:A").Cells.Find(What:="TOOTHBRUSH BATT")
' This is the cell Address (in case it keeps looping back to beginning)
Dim addy as string
if not find is nothing then addy = find.address
' If we've found a cell then Keep Do something with it
Do while not find is nothing
find.Value = "BATTERY"
' Find the next Cell
set find = Range("A:A").Cells.Find(What:="TOOTHBRUSH BATT", After:= find)
' If the next found cell is the first one then exit sub/function
if find.address = addy then exit sub
Loop
Related
I'm attemping to write a VBA module that will search through cell range A1:E400 in a Worksheet:
find a cell where there is a ",":
Cut the substring right of the "," from the cell
Insert a row below the found values' row (for the first instance of this per row, so that a new row isn't inserted multiple times as it loops
Insert the cut substring value as an offset one cell down (into the blank cell on the newly inserted row)
Trim the comma, and loop through each cell until completed
An example of the dataset I'm working with, as well as the ideal output is included below:
Data Set & Sample Output
My current VBA Module looks like this:
Sub FindDupes()
Dim rng As Range
Dim Strng As String
Set rng = Cells.Find(What:=",", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not rng Is Nothing Then
rng.Select
Else
End If
This gets me as far as finding cell values with the "," value and selecting them, but I feel like I am biting off more than I can chew here. I'm not very experienced with VBA and would love some help, I understand this is likely pretty complex..
Something I have oconsidered as a potentially easier approach would be to Text-To-Columns and vertically transpose, but ideally there would be a way for the values to insert the required rows, then paste into the empty cells as required (overwriting the cells with "," in them), e.g:
Sub Vertical()
Dim i As Long, st As String
i = 1
Dim startP As Range
For Each r In Selection
If i = 1 Then
st = r.Text
i = 2
Else
st = st & "," & r.Text
End If
Next r
Set startP = Selection(1, 2)
ary = Split(st, ",")
i = 1
For Each a In ary
startP(i, 1).Value = a
i = i + 1
Next a End Sub
Any thoughts?
something like - not tested!
dim max_commas as integer
dim count_commas as integer
For Each zelle In rngRowChosen
count_commas = Len(string)-Len(Replace(string,",",""))
if count_commas > max_commas then max_commas = count_commas
Next
insert as many rows as max_commas (replace "4" with the row number where this should go)
either
row_insert_Start = 4
Rows(row_insert_Start:row_insert_Start+max_commas).Insert
or
row_insert_Start = 4
Range("A"&row_insert_Start&":A"&row_insert_Start+max_commas).EntireRow.Insert
What I am attempting to do is reference one column to find a keyword in another column. For example:
What I will need to search is thousands of cells in column C to hundreds in Column A. When a string is found in A from C, I would like it to Highlight.
In this case after the Macro is ran the only cells that would be highlighted would be "Bird Cat" and "The Snake". What I have got so far is the following:
Sub Test()
Columns("A:A").Select
Selection.Find(What:="Bird", After:=ActiveCell, LookIn:=x1Formulas2, _
LookAt:=x1Part, SearchOrder:=x1ByRows, SearchDirection:=x1Next, _
MatchCase:=False, SearchFormulas:=False).Activate
Selection.Style = "Good"
Cells.FindNext(After:=ActiveCell).Activate
End Sub
At one point I did have a Do Until IsEmpty(ActiveCell)...Loop in the code but I was thinking that would not work.
I am still new to coding in VBA so any input in general would be welcomed.
This code employs Find and FindNext to look for a single word and mark all cells where it was found.
Sub MarkMatches(ByVal Crit As String)
' 085
Dim Rng As Range ' range to search
Dim Fnd As Range ' cell where match was found
Dim FirstFnd As Long ' row where a match was first found
Dim Arr As Variant ' Rng.Value (for execution speed)
With Worksheets("Sheet2") ' change to suit
' search in column A, starting from row 1
Set Rng = .Range(.Cells(1, "A"), _
.Cells(.Rows.Count, "A").End(xlUp))
End With
With Rng
Arr = .Value
.Interior.Pattern = xlNone ' clear existing colouring
Set Fnd = .Find(Crit, .Cells(.Cells.Count), _
xlValues, xlPart, MatchCase:=False)
If Not Fnd Is Nothing Then
FirstFnd = Fnd.Row
Do
' "1" refers to column A here:-
Arr(Fnd.Row, 1) = " " & Arr(Fnd.Row, 1) & " "
' exclude partial matches, like "catalog" matching "cat"
If InStr(1, Arr(Fnd.Row, 1), " " & Crit & " ", vbTextCompare) Then
Fnd.Interior.Color = vbYellow ' mark found match
End If
Set Fnd = .FindNext(Fnd)
If Fnd Is Nothing Then Exit Do
Loop While Fnd.Row > FirstFnd
End If
End With
End Sub
You can call the above sub with a procedure like the one given below.
Sub Macro1()
MarkMatches "bird"
End Sub
Instead of specifying the word you might specify a cell reference, like 'MarkMatches(Cells(2, "A").Value'. If you wish to search for a list of words you could place this call in a loop but you would first need to resolve how to differentiate between words marked because they match one criterion or another.
The procedure MarkMatches contains the line Rng.Interior.Pattern = xlNone which removes all previous highlights. The action of this line could be moved to the calling procedure but your present question doesn't say enough about your intentions to implement a better strategy.
I've been down this road before. Match function worked when I was using a single criteria, but I'm not able to use it properly using two criterias.
My current procedure looks on the NR_Qualtrics page to find a match on CaseID and Email. Because the columns for these can be different based on each document I get, I have procedure that identifies the row and returns which range CaseID and Email is in.
The next thing I'm doing in this function is iterating through each of the rows in NonResidential sheet trying to find a match on CaseID and Email. I need the function to return the row that the match was found on and report that in column O. Currently, I'm still stuck trying to find the matching columns. I keep getting Error 2015 and Error 2029 when I'm debugging. I'm sure that the matches exist when I look through it manually. I'm not sure what I'm doing wrong with my procedure. Can you please help?
Sub NonResFindMultipleProviders()
'This function finds any duplicate Case IDs for NR providers where they had surveys
'This function needs to run before NonRes_ChkSurveyRcd
'If there are duplicates, it will indicate that in the Notes Column (N)
'If a duplicate exists, then it must match on Email and CaseID and show the value of Yes-NR_Qualtrics Row XX/No in Survey Recieved (Column O)
Application.ScreenUpdating = False
Dim r, lastRow, rowMatch As Long
Dim colCaseID, colEmail, colResponseID As Long
Dim rngCaseID, rngEmail, rngResponseID As Range
Dim valEmail, valCaseID As String
Dim result As Variant
Dim shtNR As Worksheet
Dim shtQNR As Worksheet
Sheets("NonResidential").Select
lastRow = getLastRow
Range("A2").Select
Set shtNR = ThisWorkbook.Sheets("NonResidential")
Set shtQNR = ThisWorkbook.Sheets("NR_Qualtrics")
colCaseID = FindColHeaderWText("NR_Qualtrics", "ExternalDataReference")
Set rngCaseID = Worksheets("NR_Qualtrics").Columns(colCaseID)
colEmail = FindColHeaderWText("NR_Qualtrics", "EmailAddress")
Set rngEmail = Worksheets("NR_Qualtrics").Columns(colEmail)
'colResponseID = FindColHeaderWText("NR_Qualtrics", "ResponseID")
'Set rngResponseID = Worksheets("NR_Qualtrics").Columns(colResponseID)
'The Notes field(column N) shows the duplicates. Find matches on CaseID AND Email
''Not (IsError(Application.Match(Cells(r, 1).Value, rng, 0))) And
For r = 2 To lastRow
valCaseID = Cells(r, 1).Value 'Column A (1) has CaseIDs
valEmail = Cells(r, 12).Value 'Column L (12) has emails
result = shtNR.Evaluate("MATCH(" & valCaseID & "&" & valEmail & ",rngCaseID&rngEmail,0)")
If (Not IsError(result)) Then 'Mark only if Notes - Column N (13) is marked with a duplicate - Need to put this in next. RN, just evaluate everything
Cells(r, 15).Value = "Yes" 'Column O (14) Survey Recieved marked with Yes
End If
Next r
'Cleanup - Remove the words duplicate
'Columns("N:N").Select
'Selection.Replace What:="Duplicate", Replacement:="", LookAt:=xlWhole, _
' SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
' ReplaceFormat:=False
Application.ScreenUpdating = True
End Sub
Here's an example that matches based on 3 criteria. Try dropping your ranges and criteria into this:
Sub MatchMultipleCritera()
' Cells containing the values to match
Dim criteria1 As Range, criteria2 As Range, criteria3 As Range
Set criteria1 = Range("A1")
Set criteria2 = Range("B1")
Set criteria3 = Range("C1")
' Ranges containing the values to be checked against the match values above.
Dim rng1 As Range, rng2 As Range, rng3 As Range
Set rng1 = Range("Table1[Item]")
Set rng2 = Range("Table1[Active]")
Set rng3 = Range("Table1[Quanitity2]")
MsgBox "Row " & Evaluate("=MATCH(1,(" & criteria1.Address & "=" & rng1.Address & ")*(" & criteria2.Address & "=" & rng2.Address & ")*(" & criteria3.Address & "=" & rng3.Address & "))")
End Sub
In this example:
Cells A1, B1 and C1 contain the values I am matching.
I am looking in a table (Excel.ListObject) named "Table1" that has columns "Item", "Active" and "Quantity".
rng1 is checked for the value in criteria1, rng2 for criteria2, etc.
The result is the row number.
This is a VBA modification of this ExcelJet article using array formulas. The Evaluate function evaluates formulas as array formulas by default
I've seen variations of this question asked before, but when trying to bring the solutions together to get the result I am looking for, there ends up being something that just isn't clicking.
I want to go through all the cells in column A where they contained the "CalcText()" formula. If they do contain the formula, then they match if they contain a value of Z. If they all do, then the user-defined function reports a "Match", otherwise there is "No Match". My code is below:
Function IsAMatch() As String
Dim Cell As Range
'Look at each cell in the A column
For Each Cell In Range("A:A")
'Check if the cell does not contain the wanted text
If (InStr(0, "CalcText", Cell, vbTextCompare) > 0) Then
If (InStr(0, "Z", Cell.Value2, vbTextCompare) = 0) Then
IsAMatch = "No Match"
End If
End If
Next Cell
IsAMatch = "Match"
End Function
What I think I am doing is looping through every cell in column A and checking if it does not contain the wanted text. However, the result of the function is #Value and not either of the text result strings.
EXAMPLE:
Cell A1 contains the formula CalcText() which evaluates to Z.
This should do it:
Public Function IsAMatch()
Application.Volatile
Dim Cell As Range
Dim Ws As Worksheet
Set Ws = Application.Caller.Parent
IsAMatch = "No Match"
For Each Cell In Ws.Range("A1:A" & Ws.Cells(Ws.Rows.Count, "A").End(xlUp).Row) ' only scan used range of A:A
If (InStr(1, Cell.Formula, "calctext", vbTextCompare) > 0) And (InStr(1, Cell.Value2, "z", vbTextCompare) > 0) Then
IsAMatch = "Match"
Exit For ' added as per comment from .nomad - Exit Function could be used if no other work required.
End If
Next Cell
End Function
I've added Application.Volatile to get it to recalculate every time. Not sure if it's needed in your scenario though.
WHy not just use the find and replace function, something like this
Dim r As Excel.Range
Set r = ActiveSheet.UsedRange.Find(What:="=CalcText()", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
Set r = r.Find("z", r.Cells(1, 1), xlValues, XlLookAt.xlWhole)
r.Value = "NEW VAL"
I have the following column (column A) named project (rows column is just displaying the row number):
rows project
1 14
2 15
3 16
4 17
5 18
6 19
7 ProjTemp
8 ProjTemp
9 ProjTemp
I have an input message box where the user writes the new project name which I want inserted right after the last one. Ex: project 20 will be inserted right after project 19 and before the first "ProjTemp".
My theory was to locate the row number of the first "ProjTemp" and then insert a new row where the project is 20.
I was trying to use the Find function but I'm getting an overflow error (I'm sure I'm getting it because it's finding 3 "ProjTemp" strings and trying to set it to one parameter):
Dim FindRow as Range
with WB.Sheets("ECM Overview")
Set FindRow = .Range("A:A").Find(What:="ProjTemp", _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
MatchCase:=False)
end with
How do I code this so I only find the row number of the fist "ProjTemp"?
Is there a better way to do this, maybe a loop?
Thanks, any help will be appreciated!
I'm not really familiar with all those parameters of the Find method; but upon shortening it, the following is working for me:
With WB.Sheets("ECM Overview")
Set FindRow = .Range("A:A").Find(What:="ProjTemp", LookIn:=xlValues)
End With
And if you solely need the row number, you can use this after:
Dim FindRowNumber As Long
.....
FindRowNumber = FindRow.Row
Dim FindRow as Range
Set FindRow = Range("A:A").Find(What:="ProjTemp", _' This is what you are searching for
After:=.Cells(.Cells.Count), _ ' This is saying after the last cell in the_
' column i.e. the first
LookIn:=xlValues, _ ' this says look in the values of the cell not the formula
LookAt:=xlWhole, _ ' This look s for EXACT ENTIRE MATCH
SearchOrder:=xlByRows, _ 'This look down the column row by row
'Larger Ranges with multiple columns can be set to
' look column by column then down
MatchCase:=False) ' this says that the search is not case sensitive
If Not FindRow Is Nothing Then ' if findrow is something (Prevents Errors)
FirstRow = FindRow.Row ' set FirstRow to the first time a match is found
End If
If you would like to get addition ones you can use:
Do Until FindRow Is Nothing
Set FindRow = Range("A:A").FindNext(after:=FindRow)
If FindRow.row = FirstRow Then
Exit Do
Else ' Do what you'd like with the additional rows here.
End If
Loop
Alternatively you could use a loop, keep the row number (counter should be the row number) and stop the loop when you find the first "ProjTemp".
Then it should look something like this:
Sub find()
Dim i As Integer
Dim firstTime As Integer
Dim bNotFound As Boolean
i = 1
bNotFound = True
Do While bNotFound
If Cells(i, 2).Value = "ProjTemp" Then
firstTime = i
bNotFound = false
End If
i = i + 1
Loop
End Sub
A few comments:
Since the search position is important you should specify where you start the search. I use ws.[a1] and xlNext below so my search starts in A2 of the specified sheet.
Some of Finds arguments - including lookat use the prior search settings. So you should always specify xlWhole or xlPart to match all or part a string respectively.
You can do all you want - including inserting a row, and prompting the user for a new value (my code will suggest 20 if the prior value was 19) without using Select or Activate
suggested code
Sub FindEm()
Dim Wb As Workbook
Dim ws As Worksheet
Dim rng1 As Range
Set Wb = ThisWorkbook
Set ws = Wb.Sheets("ECM Overview")
Set rng1 = ws.Range("A:A").Find("ProjTemp", ws.[a1], xlValues, xlWhole, , xlNext)
If Not rng1 Is Nothing Then
rng1.EntireRow.Insert
rng1.Offset(-1, 0).Value = Application.InputBox("Please enter data", "User Data Entry", rng1.Offset(-2, 0) + 1, , , , , 1)
Else
MsgBox "ProjTemp not found", vbCritical
End If
End Sub
Check for "projtemp" and then check if the previous one is a number entry (like 19,18..etc..) if that is so then get the row no of that proj temp ....
and if that is not so ..then re-check that the previous entry is projtemp or a number entry ...