I'm just new to macros and have stuck with a problem. Well I got a macro file on the web that compare the two sheets and copies the found match into the 1st row.
Sub test()
Dim rng2 As Range, c2 As Range, cfind As Range
Dim x, y
With Worksheets("sheet1")
Set rng2 = Range(.Range("B2"), .Range("B2").End(xlDown))
For Each c2 In rng2
x = c2.Value
With Worksheets("sheet2").Columns("b:B")
On Error Resume Next
Set cfind = .Cells.Find(what:=x, lookat:=xlWhole)
If cfind Is Nothing Then GoTo line1
y = cfind.Offset(0, -1).Value
End With
c2.Offset(0, -1) = y
line1:
Next c2
End With
End Sub
However I didn't understand how is it exactly working? I mean I just want to reverse the existing logic. I mean I want to populate the found match in next row to the data in C column not in A.
I attempted modifying the Offset index values it didn't work. Can anyone please help me out solving this.
Thanks !
Sub test()
Dim rSh1 As Range, rSh2 As Range, rFound As Range, r As Range
With Worksheets("sheet1")
Set rSh1 = .Range("B2", .Range("B2").End(xlDown))
End With
With Worksheets("sheet2")
Set rSh2 = .Columns("b:B")
End With
For Each r In rSh1
With r
Set rFound = rSh2.Find(what:=.Value, lookat:=xlWhole)
If Not rFound Is Nothing Then
.Offset(0, 1) = rFound.Offset(0, -1).Value
End If
End With
Next r
End Sub
Related
I am very new to VBA and I am trying to solve a problem to which I can't find the answer to on here.
I have 3 columns of data,
which you can see here:
I want to write a macro with which I can search the first fruit of column D in A. If the macro finds a match I want to copy the property of the fruit (B)(e.g. Vegetable) to E next to the corresponding name.
An example:
D6=Pineapple
search for pineapple in A and then copy B4 (Fruit) to E2.
Then continue with D3 (Avocado) doing the same procedure.
This is what I came up with so far. I know it is terrible and it doesn't work at all :')
Option Explicit
Sub fruits()
Dim fruit As String
Dim i As Integer
i = 1
Do While i < 20
Set fruit = Cells(i, "D").Value
If Not fruit Is Nothing Then
Set Cells(i, "E") = Columns(1).find(fruit.Value).Offset(0, 1).Text
End If
i = i + 1
Loop
End Sub
If you have any advice or solutions I would really appreciate it.
Sorry that I am posting such a 'trivial' question, but I really don't know how to.
Thanks, NiceRice
dim rng as range, rng2 as range, rcell as range, rcell2 as range
set rng = Thisworkbook.sheets("sheetName").range("d1:d3")
set rng2 = Thisworkbook.sheets("sheetName").range("a1:a8")
for each rcell in rng.cells
if rcell.value <> vbNullstring then
for each rcell2 in rn2.cells
If rcell.value = rcell2.value then
rcell.offset(0,1).value = rcell2.value
end if
next rcell2
end if
next rcell
pretty straight forward
I agree with Scott Craner, using Vlookup is the way to go, but I thought I would share a slightly different way to accomplish the same in VBA using the Find method:
Option Explicit
Sub fruits()
Dim LastRow As Long, LastARow As Long
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
LastDRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
'get the last row with data on Column D
LastARow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
Dim rng As Range, c As Range, FoundVal As Range
Set rng = ws.Range("D1:D" & LastDRow)
For Each c In rng
Set FoundVal = ws.Range("A1:A" & LastARow).Find(What:=c.Value)
If Not FoundVal Is Nothing Then
c.Offset(0, 1).Value = FoundVal.Offset(0, 1).Value
End If
Next
End Sub
I am trying to do a partial comparison between 2 columns from 2 different sheets in the same workbook. For example: Sheet2's Column B contains the "Rs ID" and Column A contains "Clinical Significance" and in Sheet1 there are 2 columns A & B as well with the same headers.
If there is a partial match in column B of Sheet2 with column B of Sheet1, I will want my VBA code to copy the cell in Column A from Sheet2 to the same cell in in Column A in Sheet1.
Sheet 1 Sheet 2
This is my code. It runs perfectly but it doesnt seem to capture any data as the column B in sheet 2 is not exactly the same as column A. Could it be I coded the .xlpart incorrectly?
Sub test()
Dim rng2 As Range, c2 As Range, cfind As Range
Dim x, y
With Worksheets("sheet1")
Set rng2 = Range(.Range("B2"), .Range("B2").End(xlDown))
For Each c2 In rng2
x = c2.Value
With Worksheets("sheet2").Columns("b:B")
On Error Resume Next
Set cfind = .Cells.Find(what:=x, lookat:=xlpart)
If cfind Is Nothing Then GoTo line1
y = cfind.Offset(0, -1).Value
End With
c2.Offset(0, -1) = y
line1:
Next c2
End With
End Sub
Try code below.
LookIn:=xlValues was the essential missing part.
PS:
Using Goto is typically considered not good practice. I eliminated it, by using If (Not (cfind Is Nothing)).
Sub test()
Dim rng2 As Range, c2 As Range, cfind As Range
Dim x, y
With Worksheets("sheet1")
Set rng2 = .Range(.Range("B2"), .Range("B2").End(xlDown))
For Each c2 In rng2
x = c2.Value
With Worksheets("sheet2").Columns("B:B")
On Error Resume Next
Set cfind = .Cells.Find(what:=x, lookat:=xlPart, LookIn:=xlValues)
If (Not (cfind Is Nothing)) Then
y = cfind.Offset(0, -1).Value
c2.Offset(0, -1) = y
End If
End With
Next c2
End With
End Sub
I have the following code which loops through two different worksheets and compares column A to column A checking if the same value is on the other sheet. If it is then the row is colored in green.
Dim compareRange As Range
Dim toCompare As Range
Dim rFound As Range
Dim cel As Range
Set compareRange = Worksheets("sheet2").Range("A1:A" & Lastrow3)
Set toCompare = Worksheets("sheet3").Range("A1:A" & Lastrow4)
Set rFound = Nothing
For Each cel In toCompare
Set rFound = compareRange.Find(cel)
If Not rFound Is Nothing Then
cel.EntireRow.Interior.Color = 5296274
Set rFound = Nothing
End If
Next cel
Now that I have the cell with the row how do I grab the cells from the same row but on different column? because now I want to check if column L from sheet2 matches column L from sheet3. If it doesn't I want to be grab that value from sheet2 and put it in a new row below on in the same column L. Any guidance or help would be appreciated.
This should help demostrate how to do what youre after
Private Sub compAre()
Application.ScreenUpdating = False
Dim sht1 As Range
Dim rcell As Range
Set sht1 = ThisWorkbook.Sheets("Sheet1").Range("A1:A3")
For Each rcell In sht1.Cells
If rcell.Value = ThisWorkbook.Sheets("Sheet2").Range("L" & rcell.Row).Value Then
sht1.Rows.Interior.Color = vbBlue
End If
Next rcell
Application.ScreenUpdating = True
End Sub
Here's some code that covers most of what you describe, coloring the cells that match and putting those into column L of the 3rd sheet. I didn't understand the remainder of the question after that, but this should give you a good start. The animation starts by showing the contents of sheets 1,2,3 and then shows those sheets again after running the macro.
Option Explicit
Sub test()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, num As Integer
Dim r1 As Range, r2 As Range, r3 As Range, cell1 As Range, cell2 As Range
Set sh1 = Worksheets("1")
Set sh2 = Worksheets("2")
Set sh3 = Worksheets("3")
Set r1 = Range(sh1.Range("A1"), sh1.Range("A1").End(xlDown))
Set r2 = Range(sh2.Range("A1"), sh2.Range("A1").End(xlDown))
Set r3 = sh3.Range("L1")
For Each cell1 In r1
For Each cell2 In r2
If cell1 = cell2 Then
cell1.Interior.Color = vbGreen
cell2.Interior.Color = vbGreen
r3 = cell1.Value
Set r3 = r3.Offset(1, 0)
num = num + 1
End If
Next
Next
MsgBox (num & " were found to match")
End Sub
I have a workbook with 2 sheets: Masterlist (old data) and Results (new data) with unique identifiers in column A.
I'm trying to find a way to copy the row containing the most recent data from the Results tab onto the matching row in the Masterlist sheet
I have only been able to find a way to copy the new data at the bottom of the Masterlist
Sub UpdateML()
Dim wM As Worksheet, wR As Worksheet
Dim r1 As Range, r2 As Range
Dim cel1 As Range, cel2 As Range
Dim LastRow As Long
Application.ScreenUpdating = False
Set wM = ThisWorkbook.Worksheets("MasterList")
Set wR = ThisWorkbook.Worksheets("Results")
With wM
Set r1 = .Range("A1", .Cells(.Rows.Count, .Columns("A:A").Column).End(xlUp))
End With
With wR
Set r2 = .Range("A1", .Cells(.Rows.Count, .Columns("A:A").Column).End(xlUp))
End With
On Error Resume Next
For Each cel1 In r1
With Application
Set cel2 = .Index(r2, .Match(cel1.Value, r2, 0)) 'find match in Masterlist
If Err = 0 Then
copyResult cel2 'copy result to masterlist
End If
Err.Clear
End With
Next cel1
End Sub
Sub copyResult(cel As Range)
Dim w As Worksheet, r As Range
Set w = ThisWorkbook.Worksheets("Masterlist")
Set r = w.Cells(w.Rows.Count, Columns("A:A").Column).End(xlUp).Offset(1) 'next row
cel.EntireRow.Copy w.Cells(r.Row, 1)
End Sub
Your copyResult method (when setting the value of r) is picking up the bottom row + 1, so that's why it's being dumped at the bottom of the list.
You have a LastRow variable in the UpdateML method though, which is unused.
I've got it to work by using that as a counter variable to track the row index and passing that into the copyResult method. Like this:
Sub UpdateML()
Dim wM As Worksheet, wR As Worksheet
Dim r1 As Range, r2 As Range
Dim cel1 As Range, cel2 As Range
Dim LastRow As Long
Application.ScreenUpdating = False
Set wM = ThisWorkbook.Worksheets("MasterList")
Set wR = ThisWorkbook.Worksheets("Results")
With wM
Set r1 = .Range("A1", .Cells(.Rows.Count, .Columns("A:A").Column).End(xlUp))
End With
With wR
Set r2 = .Range("A1", .Cells(.Rows.Count, .Columns("A:A").Column).End(xlUp))
End With
LastRow = 1
On Error Resume Next
For Each cel1 In r1
With Application
Set cel2 = .Index(r2, .Match(cel1.Value, r2, 0)) 'find match in Masterlist
If Err = 0 Then
copyResult cel2, LastRow 'copy result to masterlist
End If
Err.Clear
LastRow = LastRow + 1
End With
Next cel1
End Sub
Sub copyResult(cel As Range, row As Long)
Dim w As Worksheet
Set w = ThisWorkbook.Worksheets("Masterlist")
cel.EntireRow.Copy w.Cells(row, 1)
End Sub
I'm a little rusty with VBA (not used it in around a year), so there may be more elegant solutions, but this is definitely one option.
Here is a different approach. It uses "Find" which is a little leaner. It also uses activesheets and cells rather than references.
Do you need to add missing items from Results to the Master list? This covers that. If Results col A is the same as MasterList col A this will also work
Sub itworks()
'''covers the above
On Error Resume Next ''Can change this to more preferred if error <> 0
Sheets("MasterList").Range("a1").Select
lo = Range("A" & Range("A:A").Rows.Count).End(xlUp).Offset(1).Address
Do Until ActiveCell.Address = lo
Sheets("Results").Range("A:A").Find(ActiveCell.Value).EntireRow.Copy ActiveCell''copies found row to your Active Cell
ActiveCell.Offset(1).Select
Loop
''Adds missing rows
Sheets("Results").Activate
Range("a1").Select
lo2 = Range("A" & Range("A:A").Rows.Count).End(xlUp).Offset(1).Address
Do Until ActiveCell.Address = lo2
Set missing = Sheets("MasterList").Range("A:A").Find(ActiveCell.Value)
If missing Is Nothing Then
ActiveCell.EntireRow.Copy Sheets("MasterList").Range("a1").End(xlDown).Offset(1)
End If
ActiveCell.Offset(1).Select
Loop
End Sub
Sheet1 Sheet2
Above i have two images link that i have captured from my excel document (Sheet1, Sheet 2)
Here's a brief description basically, I just want my macros to compare Part Number (column C) from both sheets and find out the differences. And when a string differences is detected between both sheets it will highlight the row on both sheet of BOM-list to indicate to the user the differences in the Part-number(column C). But that is a problem too as seen in the images there is some rows with "space" which the loop have to take care of to prevent comparing an empty string thus giving wrong result.
Sorry for my poor command of English and explanation if its not clear to you. Can someone guide me on this i'm rather aimless on where or how to start and i have to complete this within a week without prior knowledge on excel-VBA programming understanding.
Updated:
I have updated my post can someone take a look and give me your opinion on how i can change the code to highlight the whole row of column A to P instead of column C Range value differences only?
Sub differences()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Integer, lastrow2 As Integer
Dim rng1 As Range, rng2 As Range, temp As Range, found As Range
Application.ScreenUpdating = False
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
lastRow1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
lastrow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
Set rng1 = ws1.Range("C21:C" & lastRow1)
Set rng2 = ws2.Range("C21:C" & lastrow2)
For Each temp In rng1
Set found = Find_Range(temp.Value, rng2, , xlWhole)
If found Is Nothing Then
temp.Interior.ColorIndex = 3
End If
Next temp
For Each temp In rng2
Set found = Find_Range(temp.Value, rng1, , xlWhole)
If found Is Nothing Then
temp.Interior.ColorIndex = 3
End If
Next temp
End Sub
Function Find_Range(Find_Item As Variant, Search_Range As Range, Optional LookIn As Variant, Optional LookAt As Variant, Optional MatchCase As Boolean) As Range
Dim c As Range
Dim firstAddress As String
If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
If IsMissing(LookAt) Then LookAt = xlPart 'xlWhole
If IsMissing(MatchCase) Then MatchCase = False
With Search_Range
Set c = .Find(What:=Find_Item, LookIn:=LookIn, LookAt:=LookAt, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=MatchCase, SearchFormat:=False)
If Not c Is Nothing Then
Set Find_Range = c
firstAddress = c.Address
Do
Set Find_Range = Union(Find_Range, c)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Function
As I cant see the the images, I will make the assumption that what you are trying to do is check if a part number exists in the other list and if not then highlight it.
Off the top of my head this is what you will basically need to do.
Public Sub Test()
CompareRange Sheet1.Range("A2", "A8"), Sheet2.Range("A2", "A8")
End Sub
Public Sub CompareRange(range1 As Range, range2 As Range)
Dim CompareCell As Range
Dim CheckCell As Range
Dim CellFound As Boolean
For Each CompareCell In range1.Cells
CellFound = False
For Each CheckCell In range2.Cells
If CheckCell.Text = CompareCell.Text Then
CellFound = True
End If
Next CheckCell
If Not CellFound Then
CompareCell.Interior.Color = vbYellow
End If
Next CompareCell
End Sub
One thing to note is that this function assumes that you have a single column range. otherwise it will check all the cells in your ranges and probably highlight more than you intended.
EDIT
As far as Highlighting the Row
try adding this to your find loop
Dim CompareSheet as Worksheet 'Add at top of function
'Add to the For Each Loop
Set CompareSheet = temp.Worksheet
CompareSheet.Range("A" & temp.Row, "P" & temp.Row).Interior.ColorIndex = 3