My code searches for custom text and highlights the rows containg the user specified text/ search string.
How do I modify it so it searches for multiple strings?
Dim Rng As Range
Dim myCell As Object
Dim myUnion As Range
Set Rng = Selection
searchString = InputBox("Please Enter the Search String")
For Each myCell In Rng
If InStr(myCell.Text, searchString) Then
If Not myUnion Is Nothing Then
Set myUnion = Union(myUnion, myCell.EntireRow)
Else
Set myUnion = myCell.EntireRow
End If
End If
Next
If myUnion Is Nothing Then
MsgBox "The text was not found in the selection"
Else
myUnion.Select
End If
End Sub
Please, try the next adapted code. You should place the strings to be searched separated by comma:
Sub searchStringS()
Dim Rng As Range, myUnion As Range, searchString As String
Dim myCell As Range, arrSrc, El
Set Rng = Selection
If TypeName(Rng) <> "Range" Then MsgBox "You must select a range...", vbCritical, "Wrong selection": Exit Sub
searchString = InputBox("Please Enter the Search Strings, separated by comma!")
searchString = Replace(searchString, ", ", ",") 'to eliminate eventual ", " instead of only ","...
arrSrc = Split(searchString, ",")
For Each El In arrSrc
For Each myCell In Rng
If InStr(myCell.Text, El) Then
If Not myUnion Is Nothing Then
Set myUnion = Union(myUnion, myCell.EntireRow)
Else
Set myUnion = myCell.EntireRow
End If
End If
Next
Next El
If myUnion Is Nothing Then
MsgBox "The text was not found in the selection"
Else
myUnion.Select
End If
End Sub
Another way to do this, using ParamArray:
Public Sub fnTestSearch()
Call fnSearchMultipleStrings("01", "2022", "A", "B", "V")
End Sub
Public Sub fnSearchMultipleStrings(ParamArray aArgumentsArray() As Variant)
Dim vArg As Variant
Dim rngMyCell As Excel.Range
Dim rngMyUnion As Excel.Range
For Each vArg In aArgumentsArray
For Each rngMyCell In Selection
If InStr(rngMyCell.Text, vArg) Then
If Not rngMyUnion Is Nothing Then
Set rngMyUnion = Union(rngMyUnion, rngMyCell.EntireRow)
Else
Set rngMyUnion = rngMyCell.EntireRow
End If
End If
Next
Next vArg
If rngMyUnion Is Nothing Then
MsgBox "The text was not found in the selection"
Else
rngMyUnion.Select
End If
End Sub
Related
This VBA takes a lot of time to execute
Sub test()
Dim IB As String
Dim copyRng As Range, cel As Range, pasteRng As Range
With Selection
Set copyRng = Selection
End With
IB = Application.InputBox("Enter Exact Sheet Name to Paste")
Set pasteRng = Sheets(IB).Range("A1")
For Each cel In copyRng
cel.Copy
pasteRng.Range(cel.Address).PasteSpecial xlPasteAll
Next
Application.CutCopyMode = False
End Sub
Copy Non-Contiguous Ranges
I've turned off screen updating and replaced looping through cells with looping through areas of the range.
When you would only need values to be copied, another (vast) improvement in performance would be to copy by assignment. Then in the loop, you would use the following code:
darg.Value = sarg.Value
instead of sarg.Copy darg.
Option Explicit
Sub CopyNonContiguous()
Const ProcTitle As String = "Copy Non-Contiguous"
Dim srg As Range
If TypeName(Selection) = "Range" Then
Set srg = Selection
Else
MsgBox "Select a range. please.", vbCritical, ProcTitle
Exit Sub
End If
Dim wsName As Variant
wsName = Application.InputBox( _
"Enter Sheet Name to Paste", ProcTitle, , , , , , 2)
If wsName = False Then
MsgBox "You canceled.", vbExclamation, ProcTitle
Exit Sub
End If
Dim dws As Worksheet
On Error Resume Next
Set dws = ActiveWorkbook.Worksheets(wsName) ' consider 'ThisWorkbook'
On Error GoTo 0
If dws Is Nothing Then
MsgBox "The worksheet '" & wsName & "' doesn't exist.", _
vbCritical, ProcTitle
Exit Sub
End If
Application.ScreenUpdating = False
Dim sarg As Range
Dim darg As Range
For Each sarg In srg.Areas
Set darg = dws.Range(sarg.Address)
sarg.Copy darg
Next sarg
Application.ScreenUpdating = True
MsgBox "Cells copied.", vbInformation, ProcTitle
End Sub
Sub max()
Sheets(1).Select
Sheets(1).Name = "Sheet1"
Dim rng As Range
Dim celladdress As String
Dim celling As Variant
Do Until IsEmpty(celling)
If celling > "G4" Then
Set rng = Range("G3:G1000").Find(what:="Description")
rng.Find what:="Description"
celladdress = rng.Address(-1)
celling = celladdress
Else: Call Source
End If
Loop
MsgBox "done"
End Sub
Hi im trying to find the word description in my range, if description is foudn then it should run the macro and then loop. but if the variable is empty and the variable description is not found i want the loop to end and display the msgbox. I have tried to end the loop using loop until the celling is empty but it doesnt seem to work. The variable celling is quoting as empty so im unsure why this is not working. Any help would be greatly appreicated thanks max
Max, this is worth posting as a new answer to highlight the unintuitive behaviour of FindNext. This works - better candidate for accepted answer than that above. May be a bit pedantic, as in a more elegant solution is possbile:
Sub max()
Sheets(1).Select
Sheets(1).Name = "Sheet1"
Dim rng As Range
Set rng = Range("G3:G1000")
Dim celladdress As String
Dim celladdressPrevious As String
Dim celling As Range
Set celling = rng.Find(what:="Description")
If celling Is Nothing Then
MsgBox "Not found, exiting"
Exit Sub
End If
Do
'Set celling = range.FindNext 'Keeps returning first range found! Maybe "With" block on rng will work.
If celling.Row > 4 Then
'celling.Activate
celladdress = celling.Offset(-1, 0).Address
If celladdress = celladdressPrevious Then GoTo WereDone
celladdressPrevious = celladdress
MsgBox celladdress
'Else: Call Source 'What is Source? Not this sub, is it?
End If
If celling.Row = 1000 Then Exit Sub
Set rng = Range("G" & celling.Row & ":G1000")
Set celling = rng.Find(what:="Description")
Loop Until celling Is Nothing
WereDone:
MsgBox "done"
End Sub
'Max, guessing a little at your intent - May need your help there. Does this get you closer? I don't think I can do better on a GNU/Linux box.
Sub max()
Sheets(1).Select
Sheets(1).Name = "Sheet1"
Dim rng As Range
Set rng = Range("G3:G1000")
Dim celladdress As String
Dim celling As Range
Set celling = rng.Find(what:="Description")
If celling Is Nothing Then
MsgBox "Not found, exiting"
Exit Sub
End If
Do
'Set celling = range.FindNext 'Keeps returning first range found! Maybe "With" block on rng will work.
If celling.Row > 4 Then
'celling.Activate
celladdress = celling.Offset(-1, 0).Address
MsgBox celladdress
'Else: Call Source 'What is Source? Not this sub, is it?
End If
Set celling = range.FindNext
Loop Until celling Is Nothing
MsgBox "done"
End Sub
I found this interesting code that is almost perfect for my needs.
When a cell changes value, this code save the old value in another cell.
The problem is that when I change it again, it overwrite the previous "old value". So, at the end, I only have my "N value" and my "N-1 value".
What should I do to keep all the previous values?
Let's say that I'm modifying the cell A1, the old value goes to B1.
I thought about a CONCATENATE function, save the B1 somewhere else, but I feel I'm going in a wrong way.
Thank you so much for your patience and time.
Dim xRg As Range
Dim xChangeRg As Range
Dim xDependRg As Range
Dim xDic As New Dictionary
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long
Dim xCell As Range
Dim xDCell As Range
Dim xHeader As String
Dim xCommText As String
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
xHeader = "Previous value :"
x = xDic.Keys
For I = 0 To UBound(xDic.Keys)
Set xCell = Range(xDic.Keys(I))
Set xDCell = Cells(xCell.Row, 7)
xDCell.Value = ""
xDCell.Value = xDic.Items(I)
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim I, J As Long
Dim xRgArea As Range
On Error GoTo Label1
If Target.Count > 1 Then Exit Sub
Application.EnableEvents = False
Set xDependRg = Target.Dependents
If xDependRg Is Nothing Then GoTo Label1
If Not xDependRg Is Nothing Then
Set xDependRg = Intersect(xDependRg, Range("C:C"))
End If
Label1:
Set xRg = Intersect(Target, Range("C:C"))
If (Not xRg Is Nothing) And (Not xDependRg Is Nothing) Then
Set xChangeRg = Union(xRg, xDependRg)
ElseIf (xRg Is Nothing) And (Not xDependRg Is Nothing) Then
Set xChangeRg = xDependRg
ElseIf (Not xRg Is Nothing) And (xDependRg Is Nothing) Then
Set xChangeRg = xRg
Else
Application.EnableEvents = True
Exit Sub
End If
xDic.RemoveAll
For I = 1 To xChangeRg.Areas.Count
Set xRgArea = xChangeRg.Areas(I)
For J = 1 To xRgArea.Count
xDic.Add xRgArea(J).Address, xRgArea(J).Formula
Next
Next
Set xChangeRg = Nothing
Set xRg = Nothing
Set xDependRg = Nothing
Application.EnableEvents = True
End Sub
I want a VBA code by which I can check every cell in a range with a specific text?
EG: for each cell in range (a:a)
if value of cell = "specific text"
do this
else
do that
*
How to do this in VBA Excel?
here you go, but please try to find on google first
Sub eachCell()
Dim c As Range
For Each c In Range("A1:D21")
If (c.Value = "mytext") Then 'if value of cell = "specific text"
c.Value = "other text" 'do this
Else
c.Value = "other text 2" 'do that
End If
Next c
End Sub
Using a Find loop will be quicker than looking at each cell
Sub Sample_Find()
Dim rng1 As Range
Dim rng2 As Range
Dim bCell As Range
Dim ws As Worksheet
Dim SearchString As String
Dim FoundAt As String
Set ws = Worksheets(1)
Set rng1 = ws.Columns(1)
SearchString = "specific text"
Set rng2 = rng1.Find(SearchString, , xlValues, xlWhole)
If Not rng2 Is Nothing Then
Set bCell = rng2
FoundAt = rng2.Address
MsgBox "do something here " & FoundAt
Do
Set rng2 = rng1.FindNext(After:=rng2)
If Not rng2 Is Nothing Then
If rng2.Address = bCell.Address Then Exit Do
FoundAt = FoundAt & ", " & rng2.Address
MsgBox "do something here " & rng2.Address
Else
Exit Do
End If
Loop
Else
MsgBox SearchString & " not Found"
Exit Sub
End If
MsgBox "The Search String has been found these locations: " & FoundAt
Exit Sub
End Sub
Another option to answer your post, using the AutoFilter.
Code
Option Explicit
Sub Test_AutoFilter()
Dim ws As Worksheet
Dim SearchString As String
Dim Rng As Range
Dim VisRng As Range
Dim c As Range
Set ws = Worksheets(1)
Set Rng = ws.Columns(1)
SearchString = "specific text"
Rng.AutoFilter
Rng.AutoFilter Field:=1, Criteria1:=SearchString
' set another range to only visible cells after the Filter was applied
Set VisRng = ws.Range(Cells(1, 1), Cells(1, 1).End(xlDown)).SpecialCells(xlCellTypeVisible)
If Not VisRng Is Nothing Then
' Option 1: show every cell that a SearchString was found
For Each c In VisRng
MsgBox "String match of " & SearchString & " found as cell " & c.Address
Next c
' Option 2: show all the cells that SearchString was found (in 1 message)
MsgBox "String match of " & SearchString & " found as cells " & VisRng.Address
End If
End Sub
So i need some help. Im pretty new to VBA so im having some trouble.
Well i have multiple sheets in my work book (excel). what im trying to do is, calculate the percentage of how many cells have the word "IMCOMPLETE" in column D and putting the outcome in the main sheet on a certain cell. Example:
Sub Get_Percentage()
If Range("Jackson,_Mr._Vince_R.TrainingSt'!D2:D100").Value = "IMCOMPLETE" Then
put outcome in "TotalSummery%"!E2
If Range("Carter,_Mr._Oscar_R_(Oscar)Trai'!D2:D100").Value = "IMCOMPLETE" Then
put outcome in "TotalSummery%"!E4
If Range("Taravella,_Mr._Jim_(Jim)Trainin'!D2:D100") Value = "IMCOMPLETE" Then
put outcome in "TotalSummery%"!E5
End Sub
FYI: I have like 10 sheet tabs. Not sure if this would be a macro.
Sub FindAndCountWordInExcelWorkBook(Byval SearchString As String)
SearchString = "IMCOMPLETE"
Dim oRange As Range, aCell As Range, bCell As Range
Dim ws As Worksheet
Dim ExitLoop As Boolean
Dim FoundAt As String
On Error GoTo Err
Dim i As Integer
For i = 1 To Worksheets.Count
Set ws = Worksheets(i)
Set oRange = ws.UsedRange
Dim CountOfKeyWord As Integer
Set aCell = oRange.Find(What:=SearchString, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
FoundAt = aCell.Address
Do While ExitLoop = False
Set aCell = oRange.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
CountOfKeyWord = CountOfKeyWord + 1
FoundAt = FoundAt & ", " & aCell.Address
Else
ExitLoop = True
End If
Loop
Else
' MsgBox SearchString & " not Found"
End If
Next i
MsgBox "The Search String: " & SearchString & ", appeared " & CountOfKeyWord & " times at these locations: " & FoundAt
Exit Sub
Err:
MsgBox Err.Description
End Sub
Here is a simple way to do it. I am doing it for one sheet. You can use it in a loop
Sub Sample()
Dim ws As Worksheet
Dim SearchText As String
Dim WordCount As Long, ColDTotalWordCount As Long
Dim PercentageWord As Double
Set ws = ThisWorkbook.Sheets("Sheet1")
SearchText = "IMCOMPLETE"
With ws
'~~> Count the occurances of the word "IMCOMPLETE"
WordCount = Application.WorksheetFunction.CountIf(.Columns(4), SearchText)
'~~> Count the total words in Col D
ColDTotalWordCount = Application.WorksheetFunction.CountA(.Columns(4))
'~~> Calculate Percentage
PercentageWord = WordCount / ColDTotalWordCount
Debug.Print Format(PercentageWord, "00.00%")
End With
End Sub
The above code can be also converted to a function which can be very useful when you are looping through the sheets.
Option Explicit
Sub Sample()
Dim wSheet As Worksheet
Dim TextToSearch As String
Set wSheet = ThisWorkbook.Sheets("Sheet1")
TextToSearch = "IMCOMPLETE"
Debug.Print GetPercentage(wSheet, TextToSearch)
End Sub
Function GetPercentage(ws As Worksheet, SearchText As String) As String
Dim WordCount As Long, ColDTotalWordCount As Long
Dim PercentageWord As Double
With ws
'~~> Count the occurances of the word "IMCOMPLETE"
WordCount = Application.WorksheetFunction.CountIf(.Columns(4), SearchText)
'~~> Count the total words in Col D
ColDTotalWordCount = Application.WorksheetFunction.CountA(.Columns(4))
'~~> Calculate Percentage
PercentageWord = WordCount / ColDTotalWordCount
GetPercentage = Format(PercentageWord, "00.00%")
End With
End Function