Finding multiple cell values from list - excel

I have a workbook with 2 sheets.
Sheet1 contains a list of Product Codes in column A and Column R is Current Stock Level.
Sheet2 contains a list of Product Codes in column A and Column B contains the New Stock Level.
What I want to do is replace the Current Stock Levels in Sheet1 with the New Stock Level from Sheet2.
I found some code on this site already (below) which I have adapted slightly for my purpose and it works fine but only for one Product Code (as it references A1 and B1). What I would like to do is add a Loop so it works down all products in Sheet2 but I'm not sure how to and haven't been able to adapt any similar loops I've found online for this purpose.
Any help would be appreciated, my backup plan is to just do a v-lookup in Sheet1 to bring in the Sheet2 New Stock Level values and then replace the original column but I would like to get this other way working if possible.
Private Sub CommandButton1_Click()
Dim search_range As Range, search_value As Range, _
lastcell As Range, foundcell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Set search_range = ws.Range("A1", ws.Range("A" & Rows.Count).End(xlUp))
Set lastcell = search_range.Cells(search_range.Cells.Count)
Set search_value = ThisWorkbook.Sheets("Sheet2").Range("A1")
Set foundcell = search_range.Find(What:=search_value, After:=lastcell,
LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not foundcell Is Nothing Then foundcell.Activate Else MsgBox "Not Found"
ActiveCell.Offset(0, 17).Value = Sheets("Sheet2").Range("B1").Value
End Sub

How about the following:
Private Sub CommandButton1_Click()
Dim search_range As Range, search_value As Range, lastcell As Range, foundcell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Set search_range = ws.Range("A1", ws.Range("A" & Rows.Count).End(xlUp))
Set lastcell = search_range.Cells(search_range.Cells.Count)
For i = 1 To lastcell.Row
Set search_value = ThisWorkbook.Sheets("Sheet2").Range("A" & i)
Set foundcell = search_range.Find(What:=search_value, After:=lastcell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not foundcell Is Nothing Then foundcell.Activate Else MsgBox "Not Found"
ActiveCell.Offset(0, 17).Value = Sheets("Sheet2").Range("B" & i).Value
Next i
End Sub

The idea is the following - you have two types of ranges - ranges where you search and ranges where your value should be. They are called Target and Search.
In the code below you loop through all cells in column A of the first worksheets and you look for their value in column A of the second worksheet. If you find the value, you write the value in column B of the second worksheet to the 17. column in the first worksheet:
Private Sub CommandButton1_Click()
Dim targetRange As Range
Dim targetValue As Range
Dim searchRange As Range
Dim lastSearchCell As Range
Dim foundCell As Range
Dim wsTarget As Worksheet
Dim wsSearch As Worksheet
Dim myCell As Range
Set wsTarget = ThisWorkbook.Worksheets(1)
Set wsSearch = ThisWorkbook.Worksheets(2)
With wsTarget
Set targetRange = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
End With
With wsSearch
Set searchRange = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
End With
Set lastSearchCell = searchRange.Cells(searchRange.Cells.Count)
For Each myCell In targetRange
Set foundCell = searchRange.Find(What:=myCell, After:=lastSearchCell).Offset(0, 1)
If Not foundCell Is Nothing Then
myCell.Offset(0, 17) = foundCell
Else
MsgBox "Not Found"
End If
Next myCell
End Sub

Related

Copy paste date value to last row in nested loop

Got a bunch of worksheets in the same workbook that have a specific range of interest that starts with finding string 'Green'. Let's call this Range (A) that I'm interested in copying and pasting into a master sheet to form a database in same workbook. I found some useful code and got this part to work gr8!
There is a date value in each worksheet in cell(3,3). What's missing is adding this date value from each worksheet and past it to column B in the master sheet 'Main' such that the date value extends to match the length of the pasted Range (A).
all help is appreciated
Sub FindRangeHistory()
'// in MainDB workbook for each trade sheet, copy and paste specific range into 'Main' sheet
Dim fnd As String, faddr As String
Dim rng As Range, foundCell As Range
Dim ws As Worksheet
Dim ws_count As Integer, i As Integer
ws_count = ThisWorkbook.Worksheets.Count
For i = 1 To ws_count
With ThisWorkbook
'initialize main sheet and keyword search
Set ws = .Worksheets("Main")
fnd = "New Life"
'Search for keyword in sheet
With .Worksheets(i)
Set foundCell = .Cells.Find(What:=fnd, after:=.Cells.SpecialCells(xlCellTypeLastCell), _
LookIn:=xlFormulas, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
'Test to see if anything was found
If Not foundCell Is Nothing Then
faddr = foundCell.Address
Set rng = .Range(foundCell, foundCell.End(xlDown))
Do
Set rng = Union(rng, .Range(foundCell, foundCell.End(xlDown)).Resize(, 7))
Set foundCell = .Cells.FindNext(after:=foundCell)
Loop Until foundCell.Address = faddr
Set rng = rng.Offset(1, 0)
rng.Copy
ws.Cells(Rows.Count, "C").End(xlUp).PasteSpecial Paste:=xlPasteValues
Worksheets(i).Cells(3, 3).Copy
ws.Cells(Rows.Count, "B").End(xlUp).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
End With
End With
Next i
End Sub
You could do it like this:
'...
'...
Dim nextRowC As Long, lastRowC As Long
nextRowC = ws.Cells(Rows.Count, "C").End(xlUp).Row + 1 'first empty row in ColC before paste
rng.Copy
ws.Cells(nextRowC, "C").PasteSpecial Paste:=xlPasteValues
lastRowC = ws.Cells(Rows.Count, "C").End(xlUp).Row 'last used row in ColC after paste
.Worksheets(i).Cells(3, 3).Copy
ws.Range(ws.Cells(nextRowC, "B"), ws.Cells(lastRowC, "B")). _
PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'...
'...

Excel VBA - Find and copy non-matching rows to another worksheet

I would like to compare 2 columns in the same worksheet, search for non-matching values in column A when compared to column D and copy the entire rows of these non-matching values in column A to another worksheet.
Here is a sample of the worksheet:
Therefore, I would like to compare column A with column D, find the values which do not match and copy the entire corresponding rows from Columns A and B to a new worksheet.
*Edit, I forgot to include my code
Dim CopyToRow As Integer
Dim rng1 As Range
Dim rng2 As Range
Dim cell As Range
Dim found As Range
'Start copying data to row 2 in Sheet2 (row counter variable)
CopyToRow = 2
Set rng1 = Range(ActiveSheet.Cells(2, 1), ActiveSheet.Cells(2, 1).End(xlDown))
Set rng2 = Range(ActiveSheet.Cells(4, 2), ActiveSheet.Cells(4, 2).End(xlDown))
For Each cell In rng1
Set found = rng2.Find(what:=cell, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
If Not found Is Nothing Then
cell.EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & CopyToRow)
CopyToRow = CopyToRow + 1
End If
Next cell
Many thanks and much appreciated!
I agree with Ron Rosenfeld that you should have demonstrated your own attempt. That being said, perhaps this will be of some help to you. Not the most elegant but should work provided you update references to your own sheet names.
Sub SOPractice()
Dim SearchCell As Range 'each value being checked
Dim SearchRng As Range 'column A
Dim LastRow As Long
Dim MatchFound As Range
Dim i As Long: i = 1
LastRow = YourSheet.Range("A" & Rows.Count).End(xlUp).Row
With YourSheet
Set SearchRng = .Range(.Cells(2, 1), .Cells(LastRow, 1))
Application.ScreenUpdating = False
For Each SearchCell In SearchRng
Set MatchFound = .Range("D:D").Find _
(What:=SearchCell.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If MatchFound Is Nothing Then 'No match hence copy to other sheet
.Range(SearchCell.Address, SearchCell.Offset(, 1)).Copy
YourCopyToSheet.Cells(i, 1).PasteSpecial xlPasteAll
i = i + 1
End If
Next SearchCell
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub
I have also found a solution, using a Dictionary object:
Dim Cl As Range, Rng As Range, Dic As Object
Set Dic = CreateObject("scripting.dictionary")
With Dic
For Each Cl In MyWorksheet1Name.Range("D2", MyWorksheet1Name.Range("D" & Rows.Count).End(xlUp))
.Item(Cl.Value) = Empty
Next Cl
For Each Cl In MyWorksheet1Name.Range("A2", MyWorksheet1Name.Range("A" & Rows.Count).End(xlUp))
If Not .Exists(Cl.Value) Then
If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
End If
Next Cl
End With
If Not Rng Is Nothing Then
Rng.EntireRow.Copy MyWorksheet2Name.Range("A" & Rows.Count).End(xlUp)
End If
Cheers!

Filtering Excel Data by Row and Copying a Specific Column

I've been having a bit of trouble with my Excel code. What I want to do is to search the rows by text criteria, filter/sort those rows with the specific criteria by column, and be able to copy and hold all of the values in the clipboard for an automation software to take over from that point.
So far, I have been able to sort the rows by the specified criteria (text string), but I cannot seem to figure out the code to copy only the column range (to the end of the row). I can copy the rows, but I'm not sure what the code is to copy an individual column (in this case these are all web addresses, and the column to be copied would be C). I am using Excel 2010.
Sub USPS_Select2()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long
Dim strSearch As String
Dim rng As Range
Dim cl As Object
Dim strMatch As String
Dim filterRange As Range
Dim copyRange As Range
Dim lastRow As Long
Set wb1 = Application.Workbooks.Open("\\S51\CompanyFolder\Employee Folders\Jason\TrackingDeliveryStatus.xls")
Set ws1 = wb1.Worksheets("TrackingDeliveryStatusResults")
strSearch = "usps.com"
With ws1
.AutoFilterMode = False
lRow = .Range("C" & .Rows.Count).End(xlUp).Row
With .Range("C2:C" & lRow)
.AutoFilter field:=1, Criteria1:="=*" & strSearch & "*"
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
.AutoFilterMode = False
End With
Set wb2 = Application.Workbooks.Open("C:\Users\CompanyFolder\Desktop\Excel_Test.xls")
Set ws2 = wb2.Worksheets("Sheet1")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 1
End If
copyFrom.Copy .Rows(lRow)
End With
'wb2.Save
'wb2.close
End Sub
Since you are already working only with column C in this statement:
With .Range("C2:C" & lRow)
You can just eliminate the EntireRow property from this statement
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
And it will set the range to visible cells in column C only, like this:
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
EDIT (to address issue in comment)
The line:
copyFrom.Copy .Rows(lRow)
Is going to paste the data into every column of that row. So make the line this to copy only into Column A.
copyFrom.Copy .Cells(lRow,1)

VBA Nested If / range match

I have a pretty large excel file that houses a list of employees, a few columns of paycheck data, then a fiscal week assigned to when that data was collected.
I am trying to search though this data and match an employee with a specific fiscal week in a macro. I have a solution that finds the name, but wont print out the fiscal week and it is very slow and I'm sure that there are much better ways of doing this simple task. Below is what I have, it's pretty simple and in the end I will need to capture the data in the rows but for now I am just printing to have proof of concept.
Sub loop_test()
Dim ClientTable As Range
Dim rng1 As Range, rng2 As Range, desired_emp As String, desired_fw As Integer
desired_emp = Application.InputBox("Select an Employee", Type:=8)
desired_fw = Application.InputBox("What FW would you like to do this for?", Type:=8)
Set FullName = Sheets("Query5").Range("A:A")
Set FiscalWeek = Sheets("Query5").Range("F:F")
For Each rng1 In FullName.Columns(1).Cells
If rng1.Value = desired_emp Then
matched_name = rng1.Cells.Value
For Each rng2 In FullName.Columns(1).Cells
If rng2.Value = desired_fw Then
matched_fw = rng2.Cells.Value
End If
Next
End If
Next
Range("i3").Value = matched_name
Range("j3").Value = matched_fw
End Sub
I set up an example range with names and fiscal weeks in columns A and B. Modify the code below to match the columns and range in your workbook, and set the target sheet to the appropriate place.
This code autofilters your range based on user inputs and copies the results to another sheet if there is a match:
Sub Autofilter_test()
Dim clientTable As Range
Dim desired_emp As String
Dim desired_fw As Integer
Dim MatchRange As Range
Dim tgt As Worksheet
Set clientTable = Range("A1:B8")
Set tgt = ThisWorkbook.Sheets("Sheet2")
ActiveSheet.AutoFilterMode = False
desired_emp = Application.InputBox("Select an Employee")
desired_fw = Application.InputBox("What FW would you like to do this for?")
With clientTable
.AutoFilter Field:=1, Criteria1:=desired_emp
.AutoFilter Field:=2, Criteria1:=desired_fw
End With
Call CopyFilteredData(tgt)
End Sub
Sub CopyFilteredData(tgt As Worksheet)
' by Tom Ogilvy source: http://www.contextures.com/xlautofilter03.html
Dim rng As Range
Dim rng2 As Range
With ActiveSheet.AutoFilter.Range
On Error Resume Next
Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
If rng2 Is Nothing Then
MsgBox "No data to copy"
Else
tgt.Cells.Clear
Set rng = ActiveSheet.AutoFilter.Range
rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy _
Destination:=tgt.Range("A1")
End If
ActiveSheet.ShowAllData
End Sub

InStr search and commas in a cell

I have a bunch of column of rows that contain text such as:
dog,cat,mouse
bat,dog,fly
fish,beaver,horse
I'm trying to search and highlight rows that contain certain word:
Public Sub MarkDuplicates()
Dim iWarnColor As Integer
Dim rng As Range
Dim rngCell As Variant
Dim LR As Long
Dim vVal
Dim tRow
LR = Cells(Rows.Count, "B").End(xlUp).Row
Set rng = Range("B1:B" & LR)
iWarnColor = xlThemeColorAccent2
For Each rngCell In rng.Cells
tRow = rngCell.Row
If InStr(rngCell.Value, "dog") = 1 Then
rngCell.Interior.ColorIndex = iWarnColor
Else
rngCell.Interior.Pattern = xlNone
End If
Next
End Sub
This works fine so long as the word 'dog' is the first word in the comma string, so it would highlight the first row but not row two because the word 'dog' appears after 'bat'. Do I need to strip the commas out first or is there a better way of doing this?
It looks like your ultimate goal is to color the row based on whether or not 'dog' is in a cell. Here's a different way to do it that doesn't even involve VBA (this example assumes your data is all in column A):
Make a new column to the right. Use the formula =IF(NOT(ISERROR(FIND("dog",A1))),1,0). You can hide the column later so the user doesn't see it. Basically, if it has the word 'dog' somewhere, then return 1 else 0.
Select the entire first row
Under Conditional Formatting, go to New Rule
Choose Use a Formula
For your formula, try =$B2=1
Now that you've conditionally colored one row, copy and paste format to the other rows.
All rows should now update automatically.
Extra Credit: If this data is formatted as a table object, the conditional formatting should automatically carry over to new rows as they are added.
Further to my comments above
Example 1 (Using .Find and .Findnext)
Option Explicit
Public Sub MarkDuplicates()
Dim ws As Worksheet
Dim iWarnColor As Integer
Dim rng As Range, aCell As Range, bCell As Range
Dim LR As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
iWarnColor = xlThemeColorAccent2
With ws
LR = .Range("B" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B1:B" & LR)
rng.Interior.ColorIndex = xlNone
Set aCell = rng.Find(What:="dog", LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
aCell.Interior.ColorIndex = iWarnColor
Do
Set aCell = rng.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
aCell.Interior.ColorIndex = iWarnColor
Else
Exit Do
End If
Loop
End If
End With
End Sub
Screenshot
Example 2 (Using Autofilter)
For this ensure that there is a Heading in Cell B1
Option Explicit
Public Sub MarkDuplicates()
Dim ws As Worksheet
Dim iWarnColor As Integer
Dim rng As Range, aCell As Range
Dim LR As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
iWarnColor = xlThemeColorAccent2
With ws
'~~> Remove any filters
.AutoFilterMode = False
LR = .Range("B" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B1:B" & LR)
With rng
.AutoFilter Field:=1, Criteria1:="=*dog*"
Set aCell = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
End With
If Not aCell Is Nothing Then aCell.Interior.ColorIndex = iWarnColor
'~~> Remove any filters
.AutoFilterMode = False
End With
End Sub

Resources