I'm trying to compare two list of names, and find the names who are on both lists. However the lists are not in the same order and of different lengths.
I tried a code compare the first name of the first list ("A1") to the first one in the other list ("B1"), and then compare it to the second ("B3") and so on until it matches. If it matches it writes "Match" on the third column, or "Not a match" if there is no match
Sub CompareTest()
Dim iComp As Integer, i As Integer, j As Integer
Dim str1 As string, str2 As string
For i = 1 to 20
str1 = ("A" & i)
For j = 1 to 20
str2 = ("B" & j)
iComp = StrComp(str1, str2, vbTextCompare)
Select Case iComp
Case 0
Range ("C" & i) = "Match"
Case 1
Range ("C" & i) = "Match"
End Select
If Range ("C" & i) = "Match" Then Exit For
Next j
Next i
End Sub
Right now, the code writes "Not a match" in every cell from 1 to 20 even though there are matches, and I'm not sure what's not working.
In your code, you are comparing the strings "An" and "Bn" and not the contents of the address. But even if you correct that, you are still writing "Match" if str1 is equal to or greater than str2. Probably not what you want.
You can probably do something like:
C1: =IF(COUNTIF(B:B,A1),"Match","Not a Match")
or, in code
Option Explicit
Sub matcher()
Dim WS As Worksheet
Dim C As Range, rSearch As Range, rLookup As Range
Set WS = Worksheets("sheet2")
With WS
Set rLookup = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
Set rSearch = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp))
.Columns(3).Clear
End With
For Each C In rLookup
If rSearch.Find(what:=C, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False) Is Nothing Then
C.Offset(0, 2) = "No Match"
Else
C.Offset(0, 2) = "Match"
End If
Next C
End Sub
Related
I'm needing to find the first row numbers of cell in column C that contains "120" without duplicates (data I have has more than 10 of each number code, I only need the first one). So the code should pick up the first row number containing e.g. 120, 7120, 81200.
The code I've tried below have only managed to find the first row number with cell that contained 120. For reference, AGCL is a column letter derived from another find function and tbAC is a user input into a textbox.
Dim AGCN As Long
Dim AGCL As String
Dim AGNN As Long
Dim AGNL As String
Dim i As Long
Dim RowD As Long
Dim AAC As String
Dim rng As Range
Dim rownumber As Long
Dim AGC As Range
Dim AGN As Range
Dim firstaddress As Long
Dim nextaddress As Long
Set rng = Sheet1.Columns(AGCL & ":" & AGCL).Find(what:="*" & tbAC & "*",
LookIn:=xlValues, lookat:=xlPart)
rownumber = rng.Row
Debug.Print rownumber '9
With Sheet1.Range(AGCL & ":" & AGCL)
Set c = .Find("*" & tbAC & "*", LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Value
Debug.Print firstaddress
With Me.ListBox2
.ColumnCount = 3
.ColumnWidths = "50;150;70"
.AddItem
.List(i, 0) = Str(firstaddress)
i = o + 1
End With
Do
Set c = .FindNext(c)
If c Is Nothing Then
GoTo donefinding
ElseIf firstaddress <> c.Value Then
nextaddress = c.Value
Debug.Print nextaddress 'it doesn't print any value here
'With Me.ListBox2
' .ColumnCount = 3
' .ColumnWidths = "50;150;70"
' .AddItem
' .List(i, 0) = Str(nextaddress)
' Debug.Print nextaddress
' i = o + 1
'End With
End If
Loop While c.Address <> firstaddress
End If
donefinding: Exit Sub
End With
Any help would be greatly appreciated, thank you!
Here is the Range.FindNext Function you can use to retrieve all the cells having 120.
With Sheet1.Range(AGCL & ":" & AGCL)
Set c = .Find("*" & tbAC & "*", lookin:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Set c = .FindNext(c)
If c is Nothing Then
GoTo DoneFinding
Elseif not firstaddress.value = c.value
''Whatever you want to do with the Second Found Value
debug.print c.value
End If
Loop While c.Address <> firstAddress
End If
DoneFinding:
End With
Now to check that the value already found or not, you can play in the If Condition of this loop. So that you don't get the same values again.
UPDATED: Okay I updated one last time. As mentioned, I don't know what you want to do with the extra values... but this function will output them where ever...?
good luck.
Here's a custom function that matches what you're looking for, it will return the first time that 120 appears in a cell...
Here's one more that you could use if you truly wanted "contains" only a partial match.
Function SuperSearcherTHING(ivalue As Variant, theColumn As Range) As String
Dim rCell As Range
Const theSPACER As String = "|"
For Each rCell In Intersect(theColumn.EntireColumn, theColumn.Worksheet.UsedRange).Cells
If InStr(1, rCell.Value, ivalue, vbTextCompare) > 0 Then
SuperSearcherTHING = rCell.Value & theSPACER & SuperSearcherTHING
End If
Next rCell
SuperSearcherTHING = Left(SuperSearcherTHING, Len(SuperSearcherTHING) - Len(theSPACER))
End Function
I have an excel sheet which contains two columns called ProductName and CountryCode.i wanted to concatenate all the CountryCode separated by / based on the corresponding values in the column 'ProductName' and My output would be obtained in a separate column called 'FinalResults'. Please note that I used remove duplicate function to get unique values in Column C from Column A.
I tried the below VBA code with the help of stackoverflow and got the results.
Sub ProductCountry()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet2")
Dim FoundCell As Range, SearchRange As Range, Names As Range, SearchCell As Range
Dim MyString As String, i As Long
Set SearchRange = ws.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
SearchRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("C2"), Unique:=True
ws.Range("C2").Delete Shift:=xlShiftUp
Set Names = ws.Range("C2:C" & ws.Range("C" & ws.Rows.Count).End(xlUp).Row)
For Each SearchCell In Names
Set FoundCell = SearchRange.Find(SearchCell)
For i = 1 To Application.WorksheetFunction.CountIf(SearchRange, SearchCell)
MyString = MyString & FoundCell.Offset(, 1) & "/"
Set FoundCell = SearchRange.FindNext(FoundCell)
Next i
SearchCell.Offset(, 1) = Left(MyString, Len(MyString) - 1)
MyString = ""
Next SearchCell
End Sub
Seems it works fine except for the first product PRO1. You could see it didn't concatenate the codes orderly and skipped the country code US and took the country code SG two times instead.
Can anyone help what went wrong in this script and I also got range error sometime if I use this same code for large data.
I rewrote it ...
Public Function ConcatenateCodes(ByVal strProductName As String, ByVal rngCells As Range, Optional ByVal strDelimiter As String = "/") As String
Application.Volatile
Dim objCell As Range, lngRow As Long, lngCol As Long, strThisProductName As String
Dim strCountry As String, lngBlank As Long
For lngRow = 1 To rngCells.Rows.Count
strThisProductName = Trim(rngCells.Cells(lngRow, 1))
strCountry = Trim(rngCells.Cells(lngRow, 2))
If strThisProductName & strCountry = "" Then
lngBlank = lngBlank + 1
Else
lngBlank = 0
If strProductName = strThisProductName Then
ConcatenateCodes = ConcatenateCodes & strDelimiter & strCountry
End If
End If
If lngBlank = 10 Then Exit For
Next
If ConcatenateCodes <> "" Then ConcatenateCodes = Mid(ConcatenateCodes, 2)
End Function
... I'm comfortable with the above but that's just me. It means the data doesn't need to be sorted and it will work.
Add the formula to your cell and watch it go.
If you concern about speed you should use arrays to handle your data:
Option Explicit
Public Sub CollectList()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
'read values into array
Dim InputValues() As Variant
InputValues = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(0, 1)).Value
Dim UniqueList As Object
Set UniqueList = CreateObject("Scripting.Dictionary")
'collect all products in a dictionary
Dim iRow As Long
For iRow = 1 To UBound(InputValues, 1)
If UniqueList.Exists(InputValues(iRow, 1)) Then
UniqueList(InputValues(iRow, 1)) = UniqueList(InputValues(iRow, 1)) & "/" & InputValues(iRow, 2)
Else
UniqueList.Add InputValues(iRow, 1), InputValues(iRow, 2)
End If
Next iRow
'output dictionary into cells
iRow = 2 'start output in row 2
Dim itm As Variant
For Each itm In UniqueList
ws.Cells(iRow, "C").Value = itm
ws.Cells(iRow, "D").Value = UniqueList(itm)
iRow = iRow + 1
Next itm
End Sub
As can be seen by the other responses, there are many ways to accomplish your task.
But read VBA HELP for the Range.Find method
I submit the following to help you understand where you went wrong:
This is your problem line:
Set FoundCell = SearchRange.Find(SearchCell)
You only specify the what argument for the Find. So other arguments default to some uncontrolled value. In general, the after argument will default to the beginning of the range, so the first matching term you will Find for PRO1 will be in A3. Also, the 2nd SG is being picked up because the lookat is defaulting to xlPart and PRO1 is contained within PRO10.
So one way of correcting that portion of your code, would be to be sure to specify all the relevant arguments of the Find. eg:
Set FoundCell = SearchRange.Find(what:=SearchCell, after:=SearchRange.End(xlDown), lookat:=xlWhole)
I am working on an Excel document using VBA. This document contains a database with multiple columns, but for simplicity, let's say I have 2 columns:
Column C corresponds to names
Column F corresponds to numbers.
I'm trying to create a macro that checks all the numbers in column F (with a loop). If the number is above 100, then check the adjacent cell in column C. If the name corresponds to a condition (let's say corresponds to John or Tom), then add the value of the number in another sheet. If none of those apply, check the next cell.
My problem is that I can't find a way to define the cells in column C (Creating a variable/object to call the cells or calling directly the adjacent cell).
My code looks like this:
Sub Test1()
Dim rngnumbers, rngnames, MultipleRange As Range
Set rngnumbers = Sheet2.Range("F2:F999")
Set rngnames = Sheet2.Range("C2:C999")
Set MultipleRange = Union(rngnumbers, rngnames)
For Each numb In rngnumbers
If numb.Value >= 100 Then
If Sheet2.Range("C2") = "John" Or Sheet2.Range("C2") = "Tom" Then '''The problem here is that it only looks at the cell C2 and not the adjacent cell
Sheet1.Range("I999").End(xlUp).Offset(1, 0).Value = numb.Value
Else
End If
End If
Next numb
End Sub
I tried modifying the line:
'If Sheet2.Range("C2") = "John" Or Sheet2.Range("C2") = "Tom" Then'
to something like:
'newname.String = "John" '
But I can't find a way to define newname.
Another idea would be to increment the If statement for the names within the For loop.
Additional note:
I am also not using formulas directly within Excel as I don't want any blank cells or zeros when the if functions are False.
Does this solve your problem - referencing the relevant cell in column C? OFFSET provides a relative reference, in this case look 3 columns to the left of F.
Sub Test1()
Dim rngnumbers As Range, rngnames As Range, MultipleRange As Range, numb As Range
Set rngnumbers = Sheet2.Range("F2:F999")
Set rngnames = Sheet2.Range("C2:C999")
Set MultipleRange = Union(rngnumbers, rngnames)
For Each numb In rngnumbers
If numb.Value >= 100 Then
If numb.Offset(, -3) = "John" Or numb.Offset(, -3) = "Tom" Then
Sheet1.Range("I999").End(xlUp).Offset(1, 0).Value = numb.Value
End If
End If
Next numb
End Sub
Have you considered SUMIFS instead?
You want something like this?
Sub Test1()
Dim lRow As Long, r As Long
lRow = 1000 'last row in your data
Dim ws As Worksheet
Set ws = Worksheets("List with your data")
For i = 2 To lRow
If ws.Range("F" & i) > 100 Then
If ws.Range("C" & i).Value = "John" Or ws.Range("C" & i).Value = "Tom" Then
Worksheets("Another sheet sheet").Range("A" & r) = Range("C" & i).Value ' r - Row, where we want to enter uor text
r = r + 1 'if you want to put next name on the next row
End If
End If
Next
End Sub
Two Ifs in a Loop
Union Version
Option Explicit
Sub Test1()
Const cFirst As Integer = 2
Const cLast As Integer = 999
Const cCol1 As Variant = "F"
Const cCol2 As Variant = "C"
Const cCol3 As Variant = "I"
Dim i As Integer
Dim rngU As Range
With Sheet2
For i = cFirst To cLast
If IsNumeric(.Cells(i, cCol1)) And .Cells(i, cCol1) >= 100 Then
If .Cells(i, cCol2) = "John" _
Or .Cells(i, cCol2) = "Tom" Then
If Not rngU Is Nothing Then
Set rngU = Union(rngU, .Cells(i, cCol1))
Else
Set rngU = .Cells(i, cCol1)
End If
End If
End If
Next
End With
If Not rngU Is Nothing Then
rngU.Copy Sheet1.Cells(cLast, cCol3).End(xlUp).Offset(1, 0)
Set rngU = Nothing
End If
End Sub
I normally work with arrays:
Sub Test1()
Dim rngnumbers As Excel.Range
Dim arrVals As variant
Dim lngRow As long
Arrvals = Sheet2.Range("C2:F999").value
For Lngrow = lbound(arrvals,1) to ubound(arrvals,1)
If arrvals(lngrow,4) >= 100 Then
If arrvals(lngrow,1)= "John" Or arrvals(lngrow,1) = "Tom" Then '''The problem here is that it only looks at the cell C2 and not the adjacent cell
Sheet1.Range("I999").End(xlUp).Offset(1, 0).Value = arrvals(lngrow,4)
Else
End If
End If
Next lngrow
End Sub
Actually I would probably build an output array as well, but my thumb is tired...
I am using the match function on spreadsheets and the spreadsheets have the same keywords but in different rows, I am attempting to get the row number and to do this I want to use the second instance of a keyword. How would this be done in VBA my current code is
Application.WorksheetFunction.Match("Hello", Range("A1:A100"), 0)
I was thinking about using the Index function, but I am not exactly sure how to use it.
Start the second match just below the first:
Sub dural()
Dim rw As Long
With Application.WorksheetFunction
rw = .Match("Hello", Range("A1:A1000"), 0)
rw = .Match("Hello", Range("A" & (rw + 1) & ":A1000"), 0) + rw
MsgBox rw
End With
End Sub
If you want the Nth match, I would use Find() and a FindNext() loop.
EDIT#1:
Another way to find the Nth instance is to Evaluate() the typical array formula within VBA. For N=3, in the worksheet, the array formula would be:
=SMALL(IF(A1:A1000="Hello",ROW(A1:A1000)),3)
So with VBA:
Sub dural()
Dim rw As Long, N As Long
N = 3
rw = Evaluate("SMALL(IF(A1:A1000=""Hello"",ROW(A1:A1000))," & N & ")")
MsgBox rw
End Sub
Here is a method using Range.Find.
Option Explicit
Sub FindSecond()
Dim rSearch As Range, C As Range
Const sSearchFor As String = "Hello"
Dim sFirstAddress As String
Set rSearch = Range("A1:A100")
With rSearch 'Note that search starts at the bottom
Set C = .Find(what:=sSearchFor, after:=rSearch(.Rows.Count, 1), _
LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, _
searchdirection:=xlNext, MatchCase:=False)
If Not C Is Nothing Then
sFirstAddress = C.Address
Set C = .FindNext(C)
If C.Address <> sFirstAddress Then
MsgBox "2nd instance of " & sSearchFor & " on row " & C.Row
Else
MsgBox "Only one instance of " & sSearchFor & " and it is on row " & C.Row
End If
Else
MsgBox "No instance of " & sSearchFor
End If
End With
End Sub
There might be a better way, but this works:
=MATCH("Hello",INDIRECT("A"&(1+MATCH("Hello",A1:A100,0))&":A100"),0)
This would return the index of the second occurrence, by searching for the first occurrence and using that to define the range to search for the next one.
I fully didn't understand how to follow the answer in vba deleting rows that do not contain set values defined in range (I need to use VBA for this). From what I gathered, i need to specify an array, then use some if then stuff.
In my case, I want to create something that will search just a specified column and delete all values that do not contain specific letters/numbers. 1,2,3,4,5,s,f,p,a,b,c,o are the numbers/letters i want to keep. Cells which do not contain these values (even 11 or 1s should be deleted), I want only to delete the cell (not the whole row) and shift the cells below it up (i believe you can do this with the default .delete command).
For example my columns look like this:
p
a
1
2
5
s
f
s
8
31
4
f
I want to screen my data so that all blank cells and all cells which do not contain the numbers or letter mentioned above (e.g. 31 and 8 in this case) are automatically deleted.
Thanks for your help!
Sub Tester()
Dim sKeep As String, x As Long
Dim rngSearch As Range, c As Range
'C1:C5 has values to keep
sKeep = Chr(0) & Join(Application.Transpose(Range("C1:C5").Value), _
Chr(0)) & Chr(0)
Set rngSearch = Range("A1:A100")
For x = rngSearch.Cells.Count To 1 Step -1
Set c = rngSearch.Cells(x)
If InStr(sKeep, Chr(0) & c.Value & Chr(0)) = 0 Then
c.Delete shift:=xlShiftUp
End If
Next x
End Sub
This will do
Sub Main()
Dim dontDelete
dontDelete = Array("1", "2", "3", "4", "5", "s", "f", "p", "a", "b", "c", "o")
Dim i As Long, j As Long
Dim isThere As Boolean
For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
For j = LBound(dontDelete) To UBound(dontDelete)
If StrComp(Range("A" & i), dontDelete(j), vbTextCompare) = 0 Then
isThere = True
End If
Next j
If Not isThere Then
Range("A" & i).Delete shift:=xlUp
End If
isThere = False
Next i
End Sub
Sub DeleteValues()
Dim x As Integer
Dim i As Integer
Dim Arr(1 To 3) As String
Arr(1) = "1"
Arr(2) = "2"
Arr(3) = "3"
Range("A1").Select
For x = 1 To 10
For i = 1 To 3
If ActiveCell.Value = Arr(i) Then
ActiveCell.Delete
End If
Next i
ActiveCell.Offset(1, 0).Select
Next x
End Sub
This will loop through range("a1:a10") and delete any cell where the value = any of the array values (1,2,3)
You should hopefully be able to work with this code and suit it to your needs?
Another way :) Which doesn't delete the cells in a loop.
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rngDEL As Range
Dim strDel As String
Dim arrDel
Dim i As Long
strDel = "1,11,Blah" '<~~ etc... You can pick this from a range as well
arrDel = Split(strDel, ",")
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws.Columns(1) '<~~ Change this to the relevant column
For i = LBound(arrDel) To UBound(arrDel)
.Replace What:=arrDel(i), Replacement:="", LookAt:=xlWhole, SearchOrder:= _
xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next i
On Error Resume Next
Set rngDEL = .Cells.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rngDEL Is Nothing Then rngDEL.Delete Shift:=xlShiftUp
End With
End Sub