Focusing on:
rows = w2.Columns("A:A").Find(What:=aCell, LookAt:=xlWhole).Row
Instead of looking at the whole cell to match (xlwhole), I'm trying to only match the first 6 characters of the cell. I've looked into xlpart and a few other options but have been unsuccessful.
Sub test()
Dim aCell
Dim A, B As Long, rows As Long
Dim w1, w2 As Worksheet
Dim cell As Range
Set w1 = Workbooks("Book1").Sheets("Sheet1")
Set w2 = Workbooks("Book2").Sheets("Sheet1")
A = w1.Cells(w1.Rows.Count, 1).End(xlUp).Row
B = w2.Cells(w2.Rows.Count, 1).End(xlUp).Row
For Each aCell In w1.Range("A2:A" & A)
On Error Resume Next
rows = w2.Columns("A:A").Find(What:=aCell, LookAt:=xlWhole).Row
On Error GoTo 0
If rows = 0 Then
Else
w2.Range("B" & rows).Value = aCell.Offset(0, 1).Value
End If
rows = 0
Next
End Sub
Find supports wildcards *. Use Left$ to get the first 6 characters of the cell value.
For Each aCell In w1.Range("A2:A" & A)
Dim rng As Range
Set rng = w2.Columns("A:A").Find(What:=Left$(aCell.Value, 6) & "*", LookAt:=xlWhole)
' First test if the find succeeded
If Not rng Is Nothing Then
rng.Offset(,1).Value = aCell.Offset(,1).Value
End If
Next
Related
I have a manual selection process that I have tried but failed to automate, so I am reaching out for help. I have attached an image of my Excel sheet as a visual guide when reading my process. Excel Snapshot.
I select cell "L2" and run the code below. It finds the first instance of the value within "A2:J1501" and cuts the whole row. It pastes the row onto the sheet named Lineups. Then it highlights each of the values of the cut row in column "L:L" to let me know that value has been used. I then manually select the next non-highlighted value (in the image example it would be "L2") and run the code again, and again, and again, until every row of L:L is highlighted. This process can take some time depending on the number of rows in L:L so I was hoping I can get some help to automate.
Thank you very much.
Sub ManualSelect()
Dim rng As Range
Set rng = Range("A1:J1501")
Dim ac As Range
Set ac = Application.ActiveCell
rng.Find(what:=ac).Select
Range("A" & ActiveCell.Row).Resize(1, 10).Cut
ActiveWindow.ScrollRow = 1
Sheets("Lineups").Select
nextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(nextRow, 1).Select
ActiveSheet.Paste
Sheets("Data").Select
Dim wsData As Worksheet
Dim wsLineups As Worksheet
Dim rngToSearch As Range
Dim rngLineupSet As Range
Dim rngPlayerID As Range
Dim Column As Long
Dim Row As Long
Dim LastRow As Long
Set wsData = Sheets("Data")
Set wsLineups = Sheets("Lineups")
Set rngPlayerID = wsData.Range("L2:K200")
Set rngToSearch = rngPlayerID
LastRow = wsLineups.Cells(Rows.Count, 1).End(xlUp).Row
For Row = 2 To LastRow
For Column = 1 To 10
Set rngLineupSet = rngPlayerID.Find(what:=wsLineups.Cells(Row, Column), LookIn:=xlValues)
If Not rngLineupSet Is Nothing Then rngLineupSet.Interior.Color = 65535
Next Column
Next Row
End Sub
This should be pretty close:
Sub ManualSelect()
Dim wsData As Worksheet, c As Range, dict As Object, v, rw As Range
Dim wsLineups As Worksheet, c2 As Range, f As Range
Set dict = CreateObject("scripting.dictionary") 'for tracking already-seen values
Set wsLineups = ThisWorkbook.Worksheets("Lineups")
Set wsData = ThisWorkbook.Worksheets("Data")
For Each c In wsData.Range("L2", wsData.Cells(Rows.Count, "L").End(xlUp))
v = c.Value
If dict.exists(CStr(v)) Then
c.Interior.Color = vbYellow 'already seen this value in L or a data row
Else
'search for the value in
Set f = wsData.Range("A2:J1501").Find(v, lookat:=xlWhole, LookIn:=xlValues, searchorder:=xlByRows)
If Not f Is Nothing Then
Set rw = f.EntireRow.Columns("A").Resize(1, 10) 'A to J
For Each c2 In rw.Cells 'add all values from this row to the dictionary
dict(CStr(c2)) = True
Next c2
rw.Cut Destination:=wsLineups.Cells(Rows.Count, "A").End(xlUp).Offset(1)
c.Interior.Color = vbYellow
Else
'will there always be a match?
c.Interior.Color = vbRed 'flag no matching row
End If
End If 'haven't already seen this col L value
Next c 'next Col L value
End Sub
I believe this should do it (updated):
Sub AutoSelect()
Dim wsData As Worksheet, wsLineups As Worksheet
Dim rng As Range, listIDs As Range
Set wsData = ActiveWorkbook.Sheets("Data")
Set wsLineups = ActiveWorkbook.Sheets("Lineups")
Set rng = wsData.Range("A2:J1501")
'get last row col L to define list
LastRowL = wsData.Range("L" & Rows.Count).End(xlUp).Row
Set listIDs = wsData.Range("L2:L" & LastRowL)
'loop through all cells in list
For i = 1 To listIDs.Rows.Count
myCell = listIDs.Cells(i)
'retrieve first mach in listID
checkFirst = Application.Match(myCell, listIDs, 0)
'only check first duplicate in list
If checkFirst = i Then
'get new row for target sheet as well (if sheet empty, starting at two)
newrow = wsLineups.Range("A" & Rows.Count).End(xlUp).Row + 1
'check if it is already processed
Set processedAlready = wsLineups.Cells(2, 1).Resize(newrow - 1, rng.Columns.Count).Find(What:=myCell, lookat:=xlWhole, LookIn:=xlValues)
'if so, color yellow, and skip
If Not processedAlready Is Nothing Then
listIDs.Cells(i).Interior.Color = vbYellow
Else
'get fist match for value, if any (n.b. "xlWhole" ensures whole match)
Set foundMatch = rng.Find(What:=myCell, lookat:=xlWhole, LookIn:=xlValues)
'checking for a match
If Not foundMatch Is Nothing Then
'get the row
foundRow = foundMatch.Row - rng.Cells(1).Row + 1
'specify target range and set it equal to vals from correct row in rng
wsLineups.Cells(newrow, 1).Resize(1, rng.Columns.Count).Value2 = rng.Rows(foundRow).Value
'clear contents rng row
rng.Rows(foundRow).ClearContents
'give a color to cells that actually got a match
listIDs.Cells(i).Interior.Color = vbYellow
Else
'no match
listIDs.Cells(i).Interior.Color = vbRed
End If
End If
Else
'duplicate already handled, give same color as first
listIDs.Cells(i).Interior.Color = listIDs.Cells(checkFirst).Interior.Color
End If
Next i
End Sub
Also, I think, slightly faster than the other solution offered (because of the nested loop there?). Update: I got a bit confused about the nested loop in the answer by Tim Williams, but I missed that you also want to "accept" the values in the list that matched on a row that is already gone. I fixed this in the updated version by checking if a value that fails to match on the data range has already been transferred to Lineups. Provided that doing so is permissible, this method avoids the nested loop.
I checked both methods for speed (n = 50) on a list (n = 200) for the full data range, ended up with average of 1.70x faster... But maybe speed is not such a big deal, if you're coming from manual labor :)
I am attempting to compare two columns in two separate sheets, each column contains data that is a string. My issue is that there is data in one column that is identical to the other in separate rows; therefore I have to check the entire column for the data before moving to the next. I am very inexperienced with VBA and am trying to make one portion of my job easier rather than comparing the columns by hand. I have piece wised the following code from research and trial and error. I am able to get the entire Column searched in my first Sheet, but only one value is being highlighted on the second sheet and then it is returning a value of "True" in the first column. I am unsure where I have gone wrong, any help is greatly appreciated!
Sub Better_Work_This_Time()
Dim FindString As String
Dim Rng As Range
ActiveCell = Sheets("Last Week").Range("A2").Activate
FindString = ActiveCell
Dim County As Integer
Count = Cells.CurrentRegion.rows.Count
For i = 2 To County
If Trim(FindString) <> "" Then
With Sheets("Current Week").Range("A:A")
Set Rng = .Find(What:=FindString, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
If Not Rng Is Nothing Then
ActiveCell.Font.Color = vbBlue
End If
End With
End If
If IsEmpty(FindString) Then
FindString = False
End If
ActiveCell.Offset(1, 0).Select
i = i + 1
Next
End Sub
Without using ActiveCell and using Match instead of Find.
Option Explicit
Sub Does_Work_This_Time()
Dim wb As Workbook, wsLast As Worksheet, wsCurrent As Worksheet
Dim FindString As String, ar, v
Dim LastRow As Long, i As Long, n As Long
Set wb = ThisWorkbook
' put current week values into array
Set wsCurrent = wb.Sheets("Current Week")
With wsCurrent
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
ar = .Range("A2:A" & LastRow).Value2
End With
' scan last week matching current week
Set wsLast = wb.Sheets("Last Week")
With wsLast
.Columns(1).Interior.Color = xlNone
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
FindString = Trim(.Cells(i, "A"))
If Len(FindString) > 0 Then
v = Application.Match(FindString, ar, 0)
If IsError(v) Then
'no match
ElseIf ar(v, 1) = FindString Then ' case match
.Cells(i, "A").Interior.Color = RGB(128, 255, 128) ' light green
n = n + 1
End If
End If
Next
End With
MsgBox n & " rows matched"
End Sub
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
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
I have two spreadsheets, vda.xlsx and main.xlsm. At the moment I'm comparing the values in:
main.xlsm column J
with
vda.xlsx column A
To see if there is a match. If a match is found then the value in column gets highlighted in red.
However the format of the data in vda.xlsx column A has changed .
It used to look like this
1234
Now it looks like this
Test\1234 or Best\1234 or Jest\1234 - it could be anything...
Sp I need to split Test\1234 by the "\" and extract 1234 for comparison.
Any idea how I can accomplish this. This is my code so far:
Sub VDA_Update()
Dim wshT As Worksheet
Dim wbk As Workbook
Dim wshS As Worksheet
Dim r As Long
Dim m As Long
Dim cel As Range
Application.ScreenUpdating = False
Set wshT = ThisWorkbook.Worksheets("Master")
On Error Resume Next
' Check whether vda.xlsx is already open
Set wbk = Workbooks("vda.xlsx")
On Error GoTo 0
If wbk Is Nothing Then
' If not, open it
Set wbk = Workbooks.Open("C:\Working\vda_test.xlsx")
End If
' Set worksheet on vda.xlsx
Set wshS = wbk.Worksheets("imac01")
m = wshT.Cells(wshT.Rows.Count, 1).End(xlUp).Row
' Loop though cells in column J on main.xlsm
For r = 1 To m
' Can we find the value in column C of vda.xlsx?
Set cel = wshS.Columns(1).Find(What:=wshT.Cells(r, 10).Value, _
LookAt:=xlWhole, MatchCase:=False)
If Not cel Is Nothing Then
' If we find a match, then change the text to red
wshT.Cells(r, 10).Font.ColorIndex = 3
End If
Next r
Application.ScreenUpdating = True
End Sub
Use Split(CellValue, "\") to get an array and then retrieve the last item in the array.
Change:
' Loop though cells in column J on main.xlsm
For r = 1 To m
' Can we find the value in column C of vda.xlsx?
Set cel = wshS.Columns(1).Find(What:=wshT.Cells(r, 10).Value, _
LookAt:=xlWhole, MatchCase:=False)
If Not cel Is Nothing Then
' If we find a match, then change the text to red
wshT.Cells(r, 10).Font.ColorIndex = 3
End If
Next r
To something like:
' Loop though cells in column A on vda.xlsx
For r = 1 To m
' Can we find the value in column J of main.xlsm?
cellSplit = Split(wshS.Cells(r, 1).Value, "\")
Set cel = wshT.Columns(10).Find(cellSplit(UBound(cellSplit)), _
LookAt:=xlWhole, MatchCase:=False)
If Not cel Is Nothing Then
' If we find a match, then change the text to red
cel.Cells(1, 1).Font.ColorIndex = 3
End If
Next r