Find everything that are NOT - vba

One of our customers sent me this huge excel file and one of my tasks is to build a macro that will clean up data in few sheets. Now, I found this excellent example where one user is suggesting to use the Excel Find Method to speed up the process...which BTW is working perfectly.
BUT, in my case I want to keep the matching rows and delete rest of them. How can I do that in VBA? For example, where they are saying...
Set rFound = .Columns(1).Find(What:="Cat", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=...)
How can I set the value for WHAT to 'NOT'? I tried few different things like:
Dim cat As String || cat = "Cat" || Set notCat <> cat ..... What:=notCat
DIM notCat <> "Cat" ..... What:=notCat
What:<>"Cat"
What:="<>" & cat...{I'm not sure why they suggested this way, it just changes the string from 'Cat' to '<>Cat'...which i think is wrong}
This might be a very silly question...but I just can't find the correct answer anywhere and feeling very frustrated :( Any helps will be greatly appreciated!!

With ActiveSheet.Range(Range("A1"), Cells(Rows.Count, 1).End(xlUp))
.AutoFilter Field:=1, Criteria1:="<>cat"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With

Per my comment above, and also #TimWilliams' answer, I think AutoFilter is probably the way to go with this.
I keep forgetting that Excel does not have a range Difference method (the opposite of Intersect, but that doesn't mean you can't use a similar logic with some UDF creativity.
Have a look at Chip Pearson's excellent FindAll method. Normally, Excel's .Find method only returns a single cell range (or Nothing). This is not particularly useful for your problem, since it requires you to do a clunky iteration and FindNext until you've exhausted the range.
Using the FindAll method, returns a range of all matching cells. We can then iterate over the cells in your column, and test whether they intersect the range returned from the FindAll method. If they do not intersect, then there is no match, so we can delete the row.
Sub TestFindAll()
Dim ws As Worksheet
Dim col As Range
Dim allFound As Range
Dim c As Long
Dim cl As Range
Set ws = ActiveSheet
Set col = Intersect(ws.Columns(1), ws.UsedRange)
Set allFound = FindAll(col, "Cat", xlValues, xlPart)
For c = col.Cells.Count To 1 Step -1
Set cl = col.Cells(c)
If Intersect(allFound, cl) Is Nothing Then
'cl.Interior.ColorIndex = 39 '## I use this line for debugging
cl.EntireRow.Delete
End If
Next
End Sub
'http://www.cpearson.com/excel/findall.aspx
Function FindAll(SearchRange As Range, _
FindWhat As Variant, _
Optional LookIn As XlFindLookIn = xlValues, _
Optional LookAt As XlLookAt = xlWhole, _
Optional SearchOrder As XlSearchOrder = xlByRows, _
Optional MatchCase As Boolean = False, _
Optional BeginsWith As String = vbNullString, _
Optional EndsWith As String = vbNullString, _
Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAll
' This searches the range specified by SearchRange and returns a Range object
' that contains all the cells in which FindWhat was found. The search parameters to
' this function have the same meaning and effect as they do with the
' Range.Find method. If the value was not found, the function return Nothing. If
' BeginsWith is not an empty string, only those cells that begin with BeginWith
' are included in the result. If EndsWith is not an empty string, only those cells
' that end with EndsWith are included in the result. Note that if a cell contains
' a single word that matches either BeginsWith or EndsWith, it is included in the
' result. If BeginsWith or EndsWith is not an empty string, the LookAt parameter
' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim XLookAt As XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean
CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
XLookAt = xlPart
Else
XLookAt = LookAt
End If
' this loop in Areas is to find the last cell
' of all the areas. That is, the cell whose row
' and column are greater than or equal to any cell
' in any Area.
For Each Area In SearchRange.Areas
With Area
If .Cells(.Cells.Count).Row > MaxRow Then
MaxRow = .Cells(.Cells.Count).Row
End If
If .Cells(.Cells.Count).Column > MaxCol Then
MaxCol = .Cells(.Cells.Count).Column
End If
End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
On Error GoTo 0
Set FoundCell = SearchRange.Find(what:=FindWhat, _
after:=LastCell, _
LookIn:=LookIn, _
LookAt:=XLookAt, _
SearchOrder:=SearchOrder, _
MatchCase:=MatchCase)
If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
Include = False
If BeginsWith = vbNullString And EndsWith = vbNullString Then
Include = True
Else
If BeginsWith <> vbNullString Then
If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
If EndsWith <> vbNullString Then
If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
End If
If Include = True Then
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = Application.Union(ResultRange, FoundCell)
End If
End If
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then
Exit Do
End If
Loop
End If
Set FindAll = ResultRange
End Function

Related

VBA Finding and reading multiple ranges

I'm trying to automate a file we use regularly at work. It's more or less a quote with numbers and descriptions of tasks, organized into different groups.
Usually we enter the data manually, then we have to create a Powerpoint presentation and copy-paste a lot of infos. I'm trying to automate the process so we can click on a button -> creates our Powerpoint with all the data in it.
I'm having trouble on one part : My macro currently retrieves the group names and creates slides for each group and puts the title in it. I'd like to retrieve the values of the cells of each group to paste them into the slide also. But I can't find a solution to do it... doesn't seem simple.
Range().Value can't read more than one cell. I tried setting ranges variables and retrieving the cells but no luck so far.
A lot is going on but I'll try to be as clear as possible. I'm a beginner in VBA and used a function I found online to search for our group names. I'll try to describe the code as best as I can, not everything will be relevant to the question but I guess context will help.
First the sub to find the group names that all start with the keyword "Lot" :
Public FoundCells As Range
Public FoundCell As Range
Public NomsLots As String
Sub FindLots()
Dim SearchRange As Range
Dim FindWhat As Variant
NomsLots = ""
Set SearchRange = Range("C1:C500") 'Where to search
FindWhat = "Lot" 'Value to look for
Set FoundCells = FindAll(SearchRange:=SearchRange, _
FindWhat:=FindWhat, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
MatchCase:=True, _
BeginsWith:=vbNullString, _
EndsWith:=vbNullString, _
BeginEndCompare:=vbTextCompare) 'LookIn indicates whether to look in cell values, cell formulas, or cell comments.
'The default is cell values. LookAt indicates whether to look at the entire cell (a match occurs only if the entire content of the cell matches FindWhat). The default is match entire cell.
'SearchOrder indicates whether the search should proceed row-by-row or column-by-column. The default is row-by-row.
'MatchCase indicates whether the text match is case sensitive (MatchCase = True or case insensitive (MatchCase = False). The default if False.
'BeginsWith is a string that indicates that a cell will match only if it begins with the string specified in BeginsWith.
'EndsWith is a string that indicates that a cell will match only if it ends with the string in EndsWith. The comparisons carried out against BeginsWith and EndsWith are case sensitive if BeginEndCompare is vbBinaryCompare. If BeginEndCompare is vbTextCompare, the comparison is case-insensitive. The default is vbTextCompare. If both BeginsWith and EndsWith are empty string, no tests of the cell content are performed. If either or both BeginsWith or EndsWith are not empty strings, the LookAt parameter is automatically changed to xlPart.
If FoundCells Is Nothing Then
Debug.Print "Value Not Found"
Found = False
Else
For Each FoundCell In FoundCells
NomsLots = NomsLots & FoundCell.Value & Chr(10)
Debug.Print "Value Found In Cell: " & FoundCell.Value & " in : " & FoundCell.Address
Next FoundCell
End If
NomsLots = Left(NomsLots, Len(NomsLots) - 1)
End Sub
I use it to retrieve the FoundCell.Value to get the group names contained in C1:C500. For example, "Group 1" is in C6, "Group 2" is in C13, etc. I take the values, but I can also retrieve the adresses with FoundCell.address.
I tried to retrieve FoundCell.Address and put them in a range variable but it throws an error, the formatting must be incorrect. What I wanted to do was get the different adresses, and extrapolate.
Exemple : if we have "Group 1" in C6 and "Group 2" in C13, the content of Group 1 I'm looking for is contained in cells C7 through C12. I tried offsetting the first FoundCell.Address and the next, but I couldn't make it work.
Here is the function called, btw :
Function FindAll(SearchRange As Range, _
FindWhat As Variant, _
Optional LookIn As XlFindLookIn = xlValues, _
Optional LookAt As XlLookAt = xlWhole, _
Optional SearchOrder As XlSearchOrder = xlByRows, _
Optional MatchCase As Boolean = False, _
Optional BeginsWith As String = vbNullString, _
Optional EndsWith As String = vbNullString, _
Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAll
' This searches the range specified by SearchRange and returns a Range object
' that contains all the cells in which FindWhat was found. The search parameters to
' this function have the same meaning and effect as they do with the
' Range.Find method. If the value was not found, the function return Nothing. If
' BeginsWith is not an empty string, only those cells that begin with BeginWith
' are included in the result. If EndsWith is not an empty string, only those cells
' that end with EndsWith are included in the result. Note that if a cell contains
' a single word that matches either BeginsWith or EndsWith, it is included in the
' result. If BeginsWith or EndsWith is not an empty string, the LookAt parameter
' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim XLookAt As XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean
CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
XLookAt = xlPart
Else
XLookAt = LookAt
End If
' this loop in Areas is to find the last cell
' of all the areas. That is, the cell whose row
' and column are greater than or equal to any cell
' in any Area.
For Each Area In SearchRange.Areas
With Area
If .Cells(.Cells.Count).Row > MaxRow Then
MaxRow = .Cells(.Cells.Count).Row
End If
If .Cells(.Cells.Count).Column > MaxCol Then
MaxCol = .Cells(.Cells.Count).Column
End If
End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
On Error GoTo 0
Set FoundCell = SearchRange.Find(what:=FindWhat, _
after:=LastCell, _
LookIn:=LookIn, _
LookAt:=XLookAt, _
SearchOrder:=SearchOrder, _
MatchCase:=MatchCase)
If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
Include = False
If BeginsWith = vbNullString And EndsWith = vbNullString Then
Include = True
Else
If BeginsWith <> vbNullString Then
If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
If EndsWith <> vbNullString Then
If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
End If
If Include = True Then
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = Application.Union(ResultRange, FoundCell)
End If
End If
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then
Exit Do
End If
Loop
End If
Set FindAll = ResultRange
End Function
And my code to create the powerpoint and insert slides, etc. (edited to keep the relevant only, hope I didn't break/forget anything :)) The variable Contentofthegroup doesn't exist, it's just a placeholder to understand where I want to put the data (content of the group) in the slide.
Private Sub CommandButton1_Click()
Dim PptApp As PowerPoint.Application
Dim PptDoc As PowerPoint.Presentation
Dim Diapo As PowerPoint.Slide
Dim PPTtable As PowerPoint.Table
Dim Sh As PowerPoint.Shape
Dim Cs1 As ColorScheme
Dim NbShpe As Integer
Set PptApp = CreateObject("Powerpoint.Application")
Set PptDoc = PptApp.Presentations.Open(ThisWorkbook.Path & "\" & "Powerpointpresentation.pptx")
With PptDoc
'Slide 4
'Insert Titles on a summary page
Set Sh = .Slides(4).Shapes("ShapenameTitle")
FindLots
Sh.TextFrame.TextRange.Text = "Quote for the following actions :" & Chr(13) & NomsLots
Sh.TextFrame.TextRange.Paragraphs(2).IndentLevel = 2
'Creation Slides for each group
Dim MyAr
Dim i As Long 'index of groups
Dim j As Long
Dim pptLayout As CustomLayout
j = 7
MyAr = Split(NomsLots, Chr(10))
For i = LBound(MyAr) To UBound(MyAr)
.Slides.Add Index:=j, Layout:=ppLayoutText
Set Sh = .Slides(j).Shapes("ContentShape")
Sh.TextFrame.TextRange.Text = MyAr(i) & vbCrLf & Contentofthegroup
Sh.TextFrame.TextRange.Paragraphs(2).IndentLevel = 2
j = j + 1
Next
End With
MsgBox "Done"
End Sub
So does anybody have an idea how I should proceed to achieve the desired result ? I'm not sure it is clear enough but I tried to be as thorough as possible.
Thanks.
If I understand what you're trying to accomplish, then what you need to do is to form a Range that defines the group data. In order to capture this, you need to compare the first "found" cell to the next "found" cell. The trick comes when you form the last data group.
Building off your code, I came up with this example to illustrate:
Sub FindLots()
Dim SearchRange As Range
Dim FindWhat As Variant
NomsLots = ""
Set SearchRange = Range("C1:C500") 'Where to search
FindWhat = "Lot" 'Value to look for
Set FoundCells = FindAll(SearchRange:=SearchRange, _
FindWhat:=FindWhat, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
MatchCase:=True, _
BeginsWith:=vbNullString, _
EndsWith:=vbNullString, _
BeginEndCompare:=vbTextCompare)
If FoundCells Is Nothing Then
Debug.Print "Value Not Found"
'Found = False
Else
Dim group As Range
For Each FoundCell In FoundCells
NomsLots = NomsLots & FoundCell.Value & Chr(10)
Debug.Print "Value Found In Cell: " & FoundCell.Value & " in : " & FoundCell.Address
If group Is Nothing Then
'--- first time through the loop, so capture the
' start of the group
Set group = FoundCell
Else
'--- all other times through the loop (except the last)
' we find the beginning of the next group and, logically,
' the end of the previous group
Set group = group.Offset(1, 0).Resize(FoundCell.Row - group.Row - 1, 1)
DoSomethingWithThisGroupData group
'--- we're done with the data, so set the start of the next group
Set group = FoundCell
End If
Next FoundCell
'--- now process the last group, so we have to determine where the
' end of the group data is
Dim lastRow As Long
lastRow = Cells(Cells.Rows.Count, "C").End(xlUp).Row
Set group = group.Offset(1, 0).Resize(lastRow - group.Row, 1)
DoSomethingWithThisGroupData group
End If
NomsLots = Left(NomsLots, Len(NomsLots) - 1)
End Sub
Sub DoSomethingWithThisGroupData(ByRef dataGroup As Range)
'--- something cool happens here
Debug.Print "Range of group data = " & dataGroup.Address
End Sub

Run a loop to check columns based on header name, and insert columns if they are missing

I am new to VBA and have been tasked with creating a macro to clean up and save .csv files. So far I have been able to put together the script from other answered questions here on Stack Overflow, but the final piece is eluding me.
So far I can open, check for columns that need to be deleted, delete them, then save as a new file. What I need to do is check if columns are missing and insert them so that the csv files all consistently have the same header row.
For example:
Let's say that all of the necessary columns have the first row cell values as "Alpha", "Bravo", "Charlie", "Delta", "Echo", "Foxtrot", "Golf"
But sometimes the CSV files we receive only go from "Alpha" to "Echo"
I need to check for this and then insert the columns "foxtrot" and "Golf" in their respective order. How would I go about doing this?
It seems like with minor tweaks and a little more code, I can modify my column delete script (which I found here) to do this.
Dim rngFound As Range
Dim rngDel As Range
Dim arrColumnNames() As Variant
Dim varName As Variant
Dim strFirst As String
arrColumnNames = Array("Hotel","India","Julliet")
For Each varName In arrColumnNames
Set rngFound = Rows(1).Find(varName, Cells(1, Columns.Count), xlValues, xlPart)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
If rngDel Is Nothing Then Set rngDel = rngFound Else Set rngDel = Union(rngDel, rngFound)
Set rngFound = Rows(1).Find(varName, rngFound, xlValues, xlPart)
Loop While rngFound.Address <> strFirst
End If
Next varName
If Not rngDel Is Nothing Then rngDel.EntireColumn.Delete
Set rngFound = Nothing
Set rngDel = Nothing
Erase arrColumnNames
But it's a little beyond me as I've never worked with VBA; can someone provide some direction?
The easiest way would be to put any missing columns off the right side and then sort left-to-right (rather than the typical top-to-bottom). However, I'll assume that your column header labels are not like the nice alphabetic ones you've provided so that means a custom sort and you would have to provide all of the column names for that.
The Array Filter method can quickly determine if you have columns that do not belong however it is a pattern match not an exact match so there is a possibility of false positives. Your own results will depend on the actual names of the columns header labels you use. If this is an inappropriate method then simply loop through each.
Sub fixImportColumns()
Dim c As Long, vCOLs As Variant
vCOLs = Array("Alpha", "Bravo", "Charlie", "Delta", "Echo", _
"Foxtrot", "Golf", "Hotel", "India", "Julliet")
With Worksheets("myImportedCSV")
'add non-existent columns from list
For c = LBound(vCOLs) To UBound(vCOLs)
If IsError(Application.Match(vCOLs(c), .Rows(1), 0)) Then _
.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1) = vCOLs(c)
Next c
With .Cells(1, 1).CurrentRegion
'get rid of columns not in list (from right-to-left)
For c = .Columns.Count To 1 Step -1
If UBound(Filter(vCOLs, .Cells(1, c), True, vbTextCompare)) < 0 Then _
.Columns(c).EntireColumn.Delete
Next c
'create a custom list for the sort order
Application.AddCustomList ListArray:=vCOLs
'clear any remembered sort
.Parent.Sort.SortFields.Clear
'sort the columns into the correct order
.Cells.Sort Key1:=.Rows(1), Order1:=xlAscending, _
Orientation:=xlLeftToRight, Header:=xlNo, MatchCase:=False, _
OrderCustom:=Application.CustomListCount + 1
End With
End With
End Sub
Although not widely used, the Range.Sort method can sort blocks of data from lef-to-right and use a custom list as the sort order.
This should take care of it (assuming duplicate column names are not permitted):
Sub ReorderAddDeleteCols()
Dim arrCols, x As Long, sht As Worksheet, f As Range, s
'All the fields you want in the final version (in the order needed)
arrCols = Array("Col1", "Col5", "Col2", "Col3", "Col6")
Set sht = ActiveSheet
'insert enough columns for the required fields
sht.Cells(1, 1).Resize(1, UBound(arrCols) + 1).Insert Shift:=xlToRight
x = 1
For Each s In arrCols
Set f = sht.Rows(1).Find(What:=s, LookIn:=xlValues, lookat:=xlWhole)
If Not f Is Nothing Then
'column found, move to required location
sht.Columns(f.Column).Cut sht.Cells(1, x)
Else
'not found - add header
sht.Cells(1, x).Value = s
End If
x = x + 1
Next s
'delete all other remaining columns (100 just an arbitrary value here...)
sht.Cells(1, x).Resize(1, 100).EntireColumn.Delete
End Sub
This code will work as standalone to do what you want. You can incorporate into your existing code, or simply add as a separate sub to just do this activity.
It loops through the list backward and adds any missing columns in alphabetical order.
Sub AddMissingColumns()
Dim arrColumnList() As String
arrColumnList = Split("Alpha,Bravo,Charlie,Delta,Echo,Foxtrot,Golf", ",")
Dim x As Integer
For x = UBound(arrColumnList) To LBound(arrColumnList) Step -1
Dim rngFound As Range
Set rngFound = Sheets("sheet1").Rows(1).Find(arrColumnList(x), lookat:=xlWhole)
If Not rngFound Is Nothing Then
Dim sLastFound As String
sLastFound = arrColumnList(x)
Else
If sLastFound = "" Then
With Sheets("Sheet1")
.Range("A" & .Columns.Count).End(xlToLeft).Offset(1).Value = arrColumnList(x)
End With
sLastFound = arrColumnList(x)
Else
With Sheets("Sheet1")
Dim rCheck As Range
Set rCheck = .Rows(1).Find(sLastFound, lookat:=xlWhole)
rCheck.EntireColumn.Insert shift:=xlShiftRight
rCheck.Offset(, -1).Value = arrColumnList(x)
sLastFound = arrColumnList(x)
End With
End If
End If
Next
End Sub

How to find multiple strings in VBA

Assume an Excel sheet contains the following values in a random column:
VARIABLE X
AbbA
AddA
bbAA
ccbb
KaaC
cccc
ddbb
ccdd
BBaa
ddbB
Bbaa
dbbd
kdep
mCca
mblp
ktxy
Now the column should be searched for several words and word-phrases at the same time, for example the following:
(1) "bb"
(2) "cc"
(3) "d"
I put the target strings in an array:
Dim searchFor As String
Dim xArr
searchFor = "bb/cc/d"
xArr = Split(searchFor , "/")
Also assume it does not matter if "bb" is in small letters or big letters (not case sensitive in this case). For the other cases it is case sensitive.
At the end I would like to select the respective target cases in terms of their associated rows. Please also note that I would like to include cases in the selection, where the target string (e.g. "bb") is part of a word (e.g. "dbbd").
If possible, ignore the column title ("VARIABLE X) for searching/filtering as well as in the final selection of values.
How can this be done in VBA using (1) filters and/or using (2) regular loops? Which way would you recommend?
AbBa should be either selected or deleted. I am trying to ID 'wrong cases' by applying this routine.
Further to my comments, here is an example using .Find and .FindNext
My Assumptions
We are working with Col A in Sheets("Sheet1")
My Array is predefined. You can use your array.
In the below example, I am coloring the cells red. Change as applicable.
Sub Sample()
Dim MyAr(1 To 3) As String
Dim ws As Worksheet
Dim aCell As Range, bCell As Range
Dim i As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
MyAr(1) = "bb"
MyAr(2) = "cc"
MyAr(3) = "d"
With ws
'~~> Loop through the array
For i = LBound(MyAr) To UBound(MyAr)
Set aCell = .Columns(1).Find(What:=MyAr(i), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
aCell.Interior.ColorIndex = 3
Do
Set aCell = .Columns(1).FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
aCell.Interior.ColorIndex = 3
Else
Exit Do
End If
Loop
End If
Next
End With
End Sub
Start with your data in column A, this:
Sub qwerty()
Dim i As Long, N As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To N
t = LCase(Cells(i, 1).Text)
If InStr(t, "bb") + InStr(t, "cc") + InStr(t, "d") = 0 Then
Cells(i, 1).EntireRow.Hidden = True
End If
Next i
End Sub
will hide the miscreants:
AutoFilter can be tough with more than two options.
One way to delete these would be to use the Advanced Filter. Of course, you don't need VBA for this, but using VBA:
Option Explicit
Sub FilterByStrings()
Dim rData As Range
Dim rFiltered As Range
Dim rCriteria As Range
Dim vStrings As Variant, critStrings() As Variant
Dim I As Long
vStrings = VBA.Array("bb", "cc", "d")
Set rData = Range("a1", Cells(Rows.Count, "A").End(xlUp))
Set rFiltered = Range("B1")
Set rCriteria = Range("c1")
'Add the wild cards and the column headers
ReDim critStrings(1 To 2, 1 To UBound(vStrings) + 1)
For I = 0 To UBound(vStrings)
critStrings(1, I + 1) = rData(1, 1)
critStrings(2, I + 1) = "<>*" & vStrings(I) & "*"
Next I
'criteria range
Set rCriteria = rCriteria.Resize(UBound(critStrings, 1), UBound(critStrings, 2))
rCriteria = critStrings
rData.AdvancedFilter Action:=xlFilterCopy, criteriarange:=rCriteria, copytorange:=rFiltered
rCriteria.EntireColumn.Clear
End Sub
If you want to return the cells that match those strings, you would set up the criteria range differently, removing the <> and having the criteria in a single column, rather than in adjacent rows.

Finding repetitions of values and changing the value of some other cell based on the result of search in VBA excel

I have an Excel file which I want to write a VBA code for. I want to check the values in a specific column and if some value has more than one occurrences, the value of all related rows in some other column will be summed up and set for themselves.
Let me bring you an example. I have a worksheet like this:
I check column "C". There are 3 occurrences of 0 in rows 1, 4 and 6. I sum up the value of "B1", "B4" and "B6", which will be 444 + 43434 + 43434 = 87312 and set this summation for the same columns, i.e. all "B1", "B4" and "B6" cells will have the value 87312.
I have found a code for finding all occurrences of some value and with some change it fits my problem; but I can't find related cells on the other column. This is the code I use:
Sub FindRepetitions()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Dim SearchRange As Range
Dim FindWhat As Variant
Dim FoundCells As Range
Dim FoundCell As Range
Dim Summation As Integer
Dim ColNumber As Integer
Dim RelatedCells As Range
Set ws = ActiveWorkbook.Sheets("Sheet1")
lastRow = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
Set SearchRange = ws.Range("C1:C" & lastRow)
For Each NewCell In SearchRange
FindWhat = NewCell.Value
Set FoundCells = FindAll(SearchRange:=SearchRange, _
FindWhat:=FindWhat, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
MatchCase:=False, _
BeginsWith:=vbNullString, _
EndsWith:=vbNullString, _
BeginEndCompare:=vbTextCompare)
If FoundCells.Count > 1 Then
' 2 is the Number of letter B in alphabet '
ColNumber = 2
For i = 1 To FoundCells.Count
Set RelatedCells(i) = ws.Cells(FoundCells(i).Row, ColNumber)
Next
Set Summation = Application.WorksheetFunction.Sum(RelatedCells)
For Each RelatedCell In RelatedCells
Set Cells(RelatedCell.Row, RelatedCell.Column).Value = Summation
Next RelatedCell
End If
Next
End Sub
Function FindAll(SearchRange As Range, _
FindWhat As Variant, _
Optional LookIn As XlFindLookIn = xlValues, _
Optional LookAt As XlLookAt = xlWhole, _
Optional SearchOrder As XlSearchOrder = xlByRows, _
Optional MatchCase As Boolean = False, _
Optional BeginsWith As String = vbNullString, _
Optional EndsWith As String = vbNullString, _
Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAll
' This searches the range specified by SearchRange and returns a Range object
' that contains all the cells in which FindWhat was found. The search parameters to
' this function have the same meaning and effect as they do with the
' Range.Find method. If the value was not found, the function return Nothing. If
' BeginsWith is not an empty string, only those cells that begin with BeginWith
' are included in the result. If EndsWith is not an empty string, only those cells
' that end with EndsWith are included in the result. Note that if a cell contains
' a single word that matches either BeginsWith or EndsWith, it is included in the
' result. If BeginsWith or EndsWith is not an empty string, the LookAt parameter
' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim XLookAt As XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean
CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
XLookAt = xlPart
Else
XLookAt = LookAt
End If
' this loop in Areas is to find the last cell
' of all the areas. That is, the cell whose row
' and column are greater than or equal to any cell
' in any Area.
For Each Area In SearchRange.Areas
With Area
If .Cells(.Cells.Count).Row > MaxRow Then
MaxRow = .Cells(.Cells.Count).Row
End If
If .Cells(.Cells.Count).Column > MaxCol Then
MaxCol = .Cells(.Cells.Count).Column
End If
End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
On Error GoTo 0
Set FoundCell = SearchRange.Find(what:=FindWhat, _
after:=LastCell, _
LookIn:=LookIn, _
LookAt:=XLookAt, _
SearchOrder:=SearchOrder, _
MatchCase:=MatchCase)
If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
Include = False
If BeginsWith = vbNullString And EndsWith = vbNullString Then
Include = True
Else
If BeginsWith <> vbNullString Then
If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
If EndsWith <> vbNullString Then
If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
End If
If Include = True Then
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = Application.Union(ResultRange, FoundCell)
End If
End If
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then
Exit Do
End If
Loop
End If
Set FindAll = ResultRange
End Function
I get Runtime Error '91': Object variable or With block variable not set for this line:
Set RelatedCells(i) = ws.Cells(FoundCells(i).Row, ColNumber)
I removed the Set and got the same error. What is wrong?
Based on your comment this should work:
Sub FindRepetitions()
Dim ws As Worksheet, lastRow As Long, SearchRange As Range
Set ws = ActiveWorkbook.Sheets("Sheet1")
lastRow = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
Set SearchRange = ws.Range("C1:C" & lastRow)
'~~> First determine the values that are repeated
Dim repeated As Variant, r As Range
For Each r In SearchRange
If WorksheetFunction.CountIf(SearchRange, r.Value) > 1 Then
If IsEmpty(repeated) Then
repeated = Array(r.Value)
Else
If IsError(Application.Match(r.Value,repeated,0)) Then
ReDim Preserve repeated(Ubound(repeated) + 1)
repeated(Ubound(repeated)) = r.Value
End If
End If
End If
Next
'~~> Now use your FindAll function finding the ranges of repeated items
Dim rep As Variant, FindWhat As Variant, FoundCells As Range
Dim Summation As Long
For Each rep In repeated
FindWhat = rep
Set FoundCells = FindAll(SearchRange:=SearchRange, _
FindWhat:=FindWhat, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
MatchCase:=False, _
BeginsWith:=vbNullString, _
EndsWith:=vbNullString, _
BeginEndCompare:=vbTextCompare).Offset(0, -1)
'~~> Take note that we use Offset to return Cells in B instead of C
'~~> Sum FoundCells
Summation = WorksheetFunction.Sum(FoundCells)
'~~> Output in those ranges
For Each r In FoundCells
r = Summation
Next
Next
End Sub
Not tested. Also this assumes that FindAll function works perfectly.
Also I am not explicit on using WorksheetFunction but it should work as well. HTH
Could you just use a sumif function.
The following code inserts a column (to prevent overwriting) uses a sumif function to calculate the value you want and then copies the values back into column B and erases the temporary column.
Sub temp()
Dim ws As Worksheet
Dim lastrow As Long
Set ws = ActiveWorkbook.Sheets("Sheet1")
lastrow = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
'Insert a column so nothing is overwritten
Range("E1").EntireColumn.Insert
'Assign formula
Range("E1").Formula = "=sumif(C:C,C1,B:B)"
Range("E1:E" & lastrow).FillDown
'copy value back into column B
Range("B1:B" & lastrow).Value = Range("E1:E" & lastrow).Value
'delete column
Range("E1").EntireColumn.Delete
End Sub
Just as an aside to reiterate and try and explain better what I point out in my comment re accessing a range by RelatedCells(i) where RelatedCells is a range object - this comes down to calling the Item method on the RelatedCells range object, so unless the RelatedCells object actually exists when doing so VBA will throw the type of error you are seeing, since you can't call a method on an object that doesn't exist
Another more litteral and maybe easier way to look at it is that by RelatedCells(i), you are trying to refer to the cell at the ith position:
relative to a certain cell of reference
offset from this cell of reference by a certain number of rows and columns
So you need to have some kind of reference that is set in the first place - which are all provided by the RelatedCells object:
the first cell of this range will act as the cell of reference
its shape - number of rows and columns - will determine the offset pattern
Hope that helps clarify a little

Find all matches in workbook using Excel VBA

I am trying to write a VBA routine that will take a string, search a given Excel workbook, and return to me all possible matches.
I currently have an implementation that works, but it is extremely slow as it is a double for loop. Of course the built in Excel Find function is "optimized" to find a single match, but I would like it to return an array of initial matches that I can then apply further methods to.
I will post some pseudocode of what I have already
For all sheets in workbook
For all used rows in worksheet
If cell matches search string
do some stuff
end
end
end
As previously stated, this double for loop makes things run very slowly, so I am looking to get rid of this if possible. Any suggestions?
UPDATE
While the below answers would have improved my method, I ended up going with something slightly different as I needed to do multiple queries over and over.
I instead decided to loop through all rows in my document and create a dictionary containing a key for each unique row. The value this points to will then be a list of possible matches, so that when I query later, I can simply just check if it exists, and if so, just get a quick list of matches.
Basically just doing one initial sweep to store everything in a manageable structure, and then query that structure which can be done in O(1) time
Using the Range.Find method, as pointed out above, along with a loop for each worksheet in the workbook, is the fastest way to do this. The following, for example, locates the string "Question?" in each worksheet and replaces it with the string "Answered!".
Sub FindAndExecute()
Dim Sh As Worksheet
Dim Loc As Range
For Each Sh In ThisWorkbook.Worksheets
With Sh.UsedRange
Set Loc = .Cells.Find(What:="Question?")
If Not Loc Is Nothing Then
Do Until Loc Is Nothing
Loc.Value = "Answered!"
Set Loc = .FindNext(Loc)
Loop
End If
End With
Set Loc = Nothing
Next
End Sub
Based on Ahmed's answer, after some cleaning up and generalization, including the other "Find" parameters, so we can use this function in any situation:
'Uses Range.Find to get a range of all find results within a worksheet
' Same as Find All from search dialog box
'
Function FindAll(rng As Range, What As Variant, Optional LookIn As XlFindLookIn = xlValues, Optional LookAt As XlLookAt = xlWhole, Optional SearchOrder As XlSearchOrder = xlByColumns, Optional SearchDirection As XlSearchDirection = xlNext, Optional MatchCase As Boolean = False, Optional MatchByte As Boolean = False, Optional SearchFormat As Boolean = False) As Range
Dim SearchResult As Range
Dim firstMatch As String
With rng
Set SearchResult = .Find(What, , LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)
If Not SearchResult Is Nothing Then
firstMatch = SearchResult.Address
Do
If FindAll Is Nothing Then
Set FindAll = SearchResult
Else
Set FindAll = Union(FindAll, SearchResult)
End If
Set SearchResult = .FindNext(SearchResult)
Loop While Not SearchResult Is Nothing And SearchResult.Address <> firstMatch
End If
End With
End Function
Usage is the same as native .Find, but here is a usage example as requested:
Sub test()
Dim SearchRange As Range, SearchResults As Range, rng As Range
Set SearchRange = MyWorksheet.UsedRange
Set SearchResults = FindAll(SearchRange, "Search this")
If SearchResults Is Nothing Then
'No match found
Else
For Each rng In SearchResults
'Loop for each match
Next
End If
End Sub
Function GetSearchArray(strSearch)
Dim strResults As String
Dim SHT As Worksheet
Dim rFND As Range
Dim sFirstAddress
For Each SHT In ThisWorkbook.Worksheets
Set rFND = Nothing
With SHT.UsedRange
Set rFND = .Cells.Find(What:=strSearch, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rFND Is Nothing Then
sFirstAddress = rFND.Address
Do
If strResults = vbNullString Then
strResults = "Worksheet(" & SHT.Index & ").Range(" & Chr(34) & rFND.Address & Chr(34) & ")"
Else
strResults = strResults & "|" & "Worksheet(" & SHT.Index & ").Range(" & Chr(34) & rFND.Address & Chr(34) & ")"
End If
Set rFND = .FindNext(rFND)
Loop While Not rFND Is Nothing And rFND.Address <> sFirstAddress
End If
End With
Next
If strResults = vbNullString Then
GetSearchArray = Null
ElseIf InStr(1, strResults, "|", 1) = 0 Then
GetSearchArray = Array(strResults)
Else
GetSearchArray = Split(strResults, "|")
End If
End Function
Sub test2()
For Each X In GetSearchArray("1")
Debug.Print X
Next
End Sub
Careful when doing a Find Loop that you don't get yourself into an infinite loop... Reference the first found cell address and compare after each "FindNext" statement to make sure it hasn't returned back to the first initially found cell.
You may use the Range.Find method:
http://msdn.microsoft.com/en-us/library/office/ff839746.aspx
This will get you the first cell which contains the search string. By repeating this with setting the "After" argument to the next cell you will get all other occurrences until you are back at the first occurrence.
This will likely be much faster.
Based on the idea of B Hart's answer, here's my version of a function that searches for a value in a range, and returns all found ranges (cells):
Function FindAll(ByVal rng As Range, ByVal searchTxt As String) As Range
Dim foundCell As Range
Dim firstAddress
Dim rResult As Range
With rng
Set foundCell = .Find(What:=searchTxt, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not foundCell Is Nothing Then
firstAddress = foundCell.Address
Do
If rResult Is Nothing Then
Set rResult = foundCell
Else
Set rResult = Union(rResult, foundCell)
End If
Set foundCell = .FindNext(foundCell)
Loop While Not foundCell Is Nothing And foundCell.Address <> firstAddress
End If
End With
Set FindAll = rResult
End Function
To search for a value in the whole workbook:
Dim wSh As Worksheet
Dim foundCells As Range
For Each wSh In ThisWorkbook.Worksheets
Set foundCells = FindAll(wSh.UsedRange, "YourSearchString")
If Not foundCells Is Nothing Then
Debug.Print ("Results in sheet '" & wSh.Name & "':")
Dim cell As Range
For Each cell In foundCells
Debug.Print ("The value has been found in cell: " & cell.Address)
Next
End If
Next
You can read the data into an array. From there you can do the match in memory, instead of reading one cell at a time.
Pass cell contents into VBA Array
Below code avoids creating infinite loop. Assume XYZ is the string which we are looking for in the workbook.
Private Sub CommandButton1_Click()
Dim Sh As Worksheet, myCounter
Dim Loc As Range
For Each Sh In ThisWorkbook.Worksheets
With Sh.UsedRange
Set Loc = .Cells.Find(What:="XYZ")
If Not Loc Is Nothing Then
MsgBox ("Value is found in " & Sh.Name)
myCounter = 1
Set Loc = .FindNext(Loc)
End If
End With
Next
If myCounter = 0 Then
MsgBox ("Value not present in this worrkbook")
End If
End Sub