The following VBA code colors the cells in column B if the same value appears within column D.
I would like to also color column C. Changing the range to "B:D" does not work.
Sub HighlightCellIfValueExistsinAnotherColumn()
Dim ws As Worksheet
Dim x As Integer
Dim Find As Variant
Set ws = Worksheets("Sheet5")
For x = 1 To ws.Range("B" & Rows.Count).End(xlUp).Row
Set Find = ws.Range("D:D").Find(What:=ws.Range("B" & x).Value, LookAt:=xlWhole)
If Not Find Is Nothing Then
If ws.Cells(Find.Row, 6).Value = 0 And ws.Cells(Find.Row, 9).Value = 0 Then
ws.Range("B" & x).Interior.ColorIndex = 6
End If
End If
Next x
End Sub
Just duplicate the same command:
...
ws.Range("B" & x).Interior.ColorIndex = 6
ws.Range("C" & x).Interior.ColorIndex = 6
...
Add the D column if you wish.
EDIT:
I made adjustments to your code and annotate them to explain what the code means.
I used ListObjects/Table since that is what you have given as an example. In my testing, the code highlighted A-C columns on rows 2 and 5 only.
Sub HighlightCellIfValueExistsinAnotherColumn()
Dim ws As Worksheet
Dim nRow, sourceCol, findCol As Long
Dim FoundCell As Variant
Dim lo As ListObject
Dim LookupValue As String
Set ws = Worksheets("Sheet1")
'Note: set a table name for your entire table range
'I assumed "Table1" as its name so it is arbitrary
Set lo = ws.ListObjects("Table1")
'column to iterate
sourceCol = lo.ListColumns("List2").Index
'column to search
findCol = lo.ListColumns("Animals").Index
'for each row of the list object
For nRow = 1 To lo.ListRows.Count
'what value to search
LookupValue = lo.DataBodyRange.Cells(nRow, sourceCol)
'try to find the value and return the cell
Set FoundCell = lo.DataBodyRange.Columns(findCol).Find(LookupValue, LookAt:=xlWhole)
'if value is found
If Not FoundCell Is Nothing Then
'check colums 6 and 9 if zero
If ws.Cells(FoundCell.Row, 6).Value = 0 And ws.Cells(FoundCell.Row, 9).Value = 0 Then
'color em yellow "List1", "List2" & "List3" for the current row
lo.DataBodyRange.Cells(nRow, sourceCol).Interior.ColorIndex = 6
lo.DataBodyRange.Cells(nRow, sourceCol + 1).Interior.ColorIndex = 6
lo.DataBodyRange.Cells(nRow, sourceCol - 1).Interior.ColorIndex = 6
End If
End If
Next nRow
End Sub
Related
After countless efforts to keep the array "newvarray" within range, I am now running into a result of an empty array from a 278 line column. I believe this is also the root cause of my endgame function not executing (pasting unmatched values into the rolls sheet)?
Clarification: the actualy empty cells report on locals as "Empty", the columns with string report as " "" "
Dim oldsht As Worksheet
Dim newsht As Worksheet
Dim rollsht As Worksheet
Dim a As Integer
Dim b As Integer
Dim c As Integer
Set oldsht = ThisWorkbook.Sheets("Insert Yesterday's Report Here")
Set newsht = ThisWorkbook.Sheets("Insert Today's Report Here")
Set rollsht = ThisWorkbook.Sheets("Rolls")
Dim OldVArray(), NewVArray(), RollArray() As String
ReDim Preserve OldVArray(1 To oldsht.Range("a" & Rows.Count).End(xlUp).Row - 1, 5 To 5)
ReDim Preserve NewVArray(2 To newsht.Range("a" & Rows.Count).End(xlUp).Row, 5 To 5)
ReDim Preserve RollArray(1 To rollsht.Range("a" & Rows.Count).End(xlUp).Row - 1, 3 To 3)
For a = 2 To oldsht.Range("E" & Rows.Count).End(xlUp).Row
OldVArray(a, 5) = oldsht.Cells(a, 5)
Next a
For b = 2 To newsht.Range("E" & Rows.Count).End(xlUp).Row
NewVArray(b, 5) = newsht.Cells(b, 5)
Next b
For c = 2 To rollsht.Range("C" & Rows.Count).End(xlUp).Row
RollArray(c, 3) = rollsht.Cells(c, 3)
Next c
Dim Voyage As String
For a = 2 To UBound(OldVArray)
Voyage = OldVArray(a, 5)
For b = 2 To UBound(NewVArray)
voyage2 = NewVArray(b, 5)
If voyage2 <> Voyage Then
If voyage2 <> "" Then
For Each cell In NewVArray
voyage2 = rollsheet.Range("C:C")
Next
End If
End If
Next
Next
Here are snips of sample idea, highlighted are the rows that need to be found, and the voyage that changed is in orange. Third on Rolls would be the output of the macro.
Oldsheet:
Newsheet:
Rolls:
Untested, but this is how I'd do it. Just going from your screenshots. If your actual data looks different then you will need to make some adjustments.
Sub test()
Dim wb As Workbook, oldsht As Worksheet, newsht As Worksheet, rollsht As Worksheet
Dim c As Range, id, col, cDest As Range, copied As Boolean, m
Set wb = ThisWorkbook
Set oldsht = wb.Sheets("Insert Yesterday's Report Here")
Set newsht = wb.Sheets("Insert Today's Report Here")
Set rollsht = wb.Sheets("Rolls")
'next empty row on Rolls sheet
Set cDest = rollsht.Cells(Rows.Count, "A").End(xlUp).Offset(1)
'loop colA on new sheet
For Each c In newsht.Range("A2:A" & newsht.Cells(Rows.Count, "A").End(xlUp).row).Cells
id = c.Value 'identifier from Col A
If Len(id) > 0 Then
m = Application.Match(id, oldsht.Columns("A"), 0) 'check for exact match on old sheet
If Not IsError(m) Then
'got a match: check for updates in cols B to C
copied = False
For col = 2 To 3
If c.EntireRow.Cells(col).Value <> oldsht.Cells(m, col).Value Then
If Not copied Then 'already copied this row?
cDest.Resize(1, 3).Value = c.Resize(1, 3).Value 'copy changed row
Set cDest = cDest.Offset(1) ' next empy row
copied = True
End If
cDest.EntireRow.Cells(col).Interior.Color = vbRed 'flag updated value
End If
Next col
Else
cDest.Resize(1, 3).Value = c.Resize(1, 3).Value 'copy new row
Set cDest = cDest.Offset(1) ' next empy row
End If
End If
Next c
End Sub
I'm looking to create a tool which will reconcile values across 3 spreadsheets. For example, Sheet1: ID = 123A, Country = IRELAND; Sheet2: ID = 123A, COUNTRY = UK; Sheet3: ID = 123A, COUNTRY = UK. If it does not match, we will get a FALSE value.
Currently, I have the capacity to reconcile 2 files in columns B & C in shtRecon and am looking to add a 3rd value in column D which will reconcile 3 files instead of 2.
In other words, when column B = column C, there are 0 errors, when column B <> column C, there is 1 error. I'd like it to be column B = column C = column D instead. I've included my working code for 2 column reconciliation beneath. Any ideas?
Sub ReconcileVenueRef()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim shtRecon As Worksheet
Dim shtSummary As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim cel As Range
Dim oDict As Object
Dim reconRow As Long
Dim noOfErrors As Long
Dim ETL As Variant
Dim MiFID As Variant
Dim Match As Boolean
Set sht1 = Worksheets("MiFID Export")
Set sht2 = Worksheets("ETL")
Set shtRecon = Worksheets("Reconciliation")
Set shtSummary = Worksheets("Summary")
'Define the columns that you need, and find the last row
Set rng1 = sht1.Range("A2:B" & sht1.Range("A" & sht1.Rows.Count).End(xlUp).Row)
Set rng2 = sht2.Range("A2:B" & sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row)
'Get a dictionary object holding unique values from sheet 2
'In my case, column A holds the Id, and column B holds the value
Set oDict = GetDictionary(rng2, 1, 4)
reconRow = 0
'Loop over each cel in sheet 1, column 1
'Look for the value in column 1 in the sheet 2 dictionary
'object, and then reconcile
For Each cel In Intersect(rng1, sht1.Columns(1))
'Get the next avail row in reconciliation sheet
reconRow = reconRow + 1
shtRecon.Range("A" & reconRow).Value = cel.Value
'Recon column B holds value from sheet 1, column B
shtRecon.Range("B" & reconRow).Value = cel.Offset(, 3).Value
'If Id is found in Sheet B dictionary, then take the value
'otherwise, write "blank" in column C
'ETL spreadsheet
If oDict.exists(cel.Value) Then
shtRecon.Range("C" & reconRow).Value = oDict(cel.Value)
Else
shtRecon.Range("C" & reconRow).Value = "BLANK"
End If
Next cel
'If ETL cell = MiFID cell then noOfErrors is 0, otherwise it's 1
noOfErrors = 0
ETL = shtRecon.Cells(1, 3).Value
MiFID = shtRecon.Cells(1, 2).Value
If ETL = MiFID Then
Match = True
shtRecon.Cells(1, 4).Value = Match
shtSummary.Cells(4, 3).Value = noOfErrors
ElseIf ETL <> MiFID Then
Match = False
shtRecon.Cells(1, 4).Value = Match
noOfErrors = noOfErrors + 1
shtSummary.Cells(4, 3).Value = noOfErrors
End If
End Sub
'Function stores a range into a dictionary
'Param inputRange takes a range to be stored
'Param idColumn takes the column of the range to be used as the ID
'e.g. if idColumn = 2, and inputRange("C1:F10"), then column D is used for ID
'Param valueColumn points to the column in range used for the value
Function GetDictionary(inputRange As Range, idColumn As Long, valueColumn As Long) As Object
Dim oDict As Object
Dim sht As Worksheet
Dim cel As Range
Set oDict = CreateObject("Scripting.Dictionary")
Set sht = inputRange.Parent
For Each cel In Intersect(inputRange, inputRange.Columns(idColumn))
If Not oDict.exists(cel.Value) Then
oDict.Add cel.Value, sht.Cells(cel.Row, valueColumn).Value
End If
Next cel
Set GetDictionary = oDict
End Function
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've spent the majority of my afternoon looking for a way to return a text value in a cell based on two columns. I'm looking to match a values from Sheet1, columns A & F to sheet2, returning the value in column B where these two match into sheet 1.
To visualize:
Sheet 1 Sheet 2
A F A B F
x b x c y
x g x k b
Is there a way to use VLOOKUP to do this that I missed? I'm pretty confident that I'm missing something simple, but it's giving me a hard time.
Thanks in advance!
The following Subscript does exactly what you asked:
Sub DoThaThing()
Dim i As Long, lastRow1 As Long
Dim Sheet1A As Variant, Sheet1F As Variant, firstFound As String
Dim findData As Range
lastRow1 = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To lastRow1 Step 1
Sheet1A = Sheets("Sheet1").Cells(i, "A").Value
Sheet1F = Sheets("Sheet1").Cells(i, "F").Value
Set findData = Sheets("Sheet2").Columns("A:A").Find(What:=Sheet1A, _
After:=Sheets("Sheet2").Range("A1"), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not findData Is Nothing Then
'First instance found, loop if needed
firstFound = findData.Address
Do
'Found, check Column F (5 columns over with offset)
If findData.Offset(0, 5).Value = Sheet1F Then
'A and F match get data from B (1 column over with offset)
Sheets("Sheet1").Cells(i, "B").Value = findData.Offset(0, 1).Value
Exit Do
Else
'F doesnt match, search next and recheck
Set findData = Sheets("Sheet2").Columns("A:A").FindNext(findData)
End If
Loop While Not findData Is Nothing And firstFound <> findData.Address
Else
'Value on Sheet 1 Column A was not found on Sheet 2 Column A
Sheets("Sheet1").Cells(i, "B").Value = "NOT FOUND"
End If
Next
End Sub
Edit: Infinite Loop Fixed.
try this code, it's work for me :
Option Explicit
Sub test()
' Active workbook
Dim wb As Workbook
Set wb = ThisWorkbook
Dim i As Long
Dim j As Long
'*******************************************
'Adapt this vars
'define your sheets
Dim ws_1 As Worksheet
Dim ws_2 As Worksheet
Set ws_1 = wb.Sheets("Feuil1") 'change name of the sheet to complete
Set ws_2 = wb.Sheets("Feuil2") 'change name of the sheet with all data
'definie the last Rows
Dim lastRow_ws1 As Long
Dim lastRow_ws2 As Long
lastRow_ws1 = ws_1.Range("A" & Rows.Count).End(xlUp).Row + 1 'if you need, adjust column to find last row
lastRow_ws2 = ws_2.Range("A" & Rows.Count).End(xlUp).Row + 1 'if you need, adjust column to find last row
'*******************************************
Dim keyMach1 As String
Dim keyMach2 As String
For j = 1 To lastRow_ws1
For i = 1 To lastRow_ws2
Dim keySearch As String
Dim keyFind As String
keySearch = ws_1.Cells(j, 1).Value & ws_1.Cells(j, 6).Value 'I concat both cell to create o key for the search
keyFind = ws_2.Cells(i, 1).Value & ws_1.Cells(i, 6).Value ' idem to match
If keySearch = keyFind Then
ws_1.Cells(j, 2).Value = ws_2.Cells(i, 2).Value
End If
Next i
Next j
End Sub
I have a worksheet (Sheet 1) that contains a help column AR that contains the number "5" or text "Invalid". I want column AS to do a specific vlookup if AR contains the number "5", but if it contains the text "invalid" to do a separate specific vlookup. Currently what I have just overwrites to what is done in the else section of my loop to be the last iteration over the column and just ends up doing a vlookup for one or the other. I'm using column Y in sheet 1 as the specific value (aCell) that is being used to vlookup. Any help would go a long way, thanks!
Dim wsThis As Worksheet
Dim aCell As Range
Set wsThis = Sheets("Sheet3")
Dim wsAnd As Worksheet
Set wsAnd = Sheets("Sheet2")
Dim LastRow As Long, myRng As Range
LastRow = Sheets("Sheet3").UsedRange.Rows.Count
With wsIt
For x = 2 To LastRow
If Sheets("Sheet1").Range("$AR$" & x) = "5" Then
For Each aCell In wsIt.Range("Y2:Y" & LastRow)
.Cells(aCell.Row, 45) = "Not Found"
On Error Resume Next
.Cells(aCell.Row, 45) = Application.WorksheetFunction.VLookup( _
aCell.Value, wsThis.Range("$B$2:$Q$400"), 5, False)
On Error GoTo 0
Next aCell
End If
Next
End With
With wsIt
For x = 2 To LastRow
If Sheets("Sheet1").Range("$AR$" & x) = "Invalid" Then
For Each aCell In wsIt.Range("Y2:Y" & LastRow)
.Cells(aCell.Row, 45) = "Not Found"
On Error Resume Next
.Cells(aCell.Row, 45) = Application.WorksheetFunction.VLookup( _
aCell.Value, wsAnd.Range("$B$2:$Q$400"), 5, False)
On Error GoTo 0
Next aCell
End If
Next
End With
If I correctly intended your aim, you could:
use Application.VlookUp() method to benefit from its returned value capture any error and query it
use a Select Case block to formerly choose the lookUp range in relation with column “AR” value
Dim wsIt As Worksheet
Set wsIt = Sheets("Sheet1")
Dim wsThis As Worksheet
Set wsThis = Sheets("Sheet3")
Dim wsAnd As Worksheet
Set wsAnd = Sheets("Sheet2")
Dim LastRow As Long
Dim aCell As Range
Dim lookUpResult As Variant
LastRow = wsThis.UsedRange.Rows.Count
With wsIt
For x = 2 To LastRow
Select Case .Cells(x, "AR")
Case "5"
Set VLookUpRng = wsThis.Range("$B$2:$Q$400")
Case “Invalid”
Set VLookUpRng = wsAnd.Range("$B$2:$Q$400")
Case Else
Set VLookUpRng = Nothing
End Select
If Not VLookUpRng Is Nothing Then
For Each aCell In .Range("Y2:Y" & LastRow)
lookUpResult = Application.VLookup( aCell.Value, VLookUpRng, 5, False)
.Cells(aCell.Row, 45) = IIf(IsError(lookUpResult), "Not Found", lookUpResult)
Next
End If
Next
End With
This wasnt a great solution but essentially I pasted over the vlookup results of the 2nd iteration into a new sheet and then sorted the columns of sheet 1 and sheet 2 such that the results would reference each other correctly.
Dim x as Long
Dim y As Long
Dim LastRow
Dim NewLast
LastRow = Sheets("Sheet1").UsedRange.Rows.Count
NewLast = Sheets("Sheet2").UsedRange.Rows.Count
For x = 2 to LastRow
If Sheets("Sheet1").Range("$AS$" & x) = "Not Found" Then
For y = 2 To NewLast
Sheets("Sheet1").Range("$AS$" & x) = Sheets("Sheet2").Range("$F$" & y)
Sheets("Sheet1").Range("$AT$" & x) = Sheets("Sheet2").Range("$F$" & y)
Next
End If
Next