I've seen similar posts, but nothing that has directly addressed my current problem...
I have a workbook with 2 sheets (Sheet1 and Sheet 2). In Sheet1, there are 2 columns - column A contains part numbers from our old ERP system and column B contains weights. In Sheet2, I have 2 columns - column A contains part numbers from our new ERP system and column B contains alias part numbers.
I would like to have a macro read in the part number in Sheet1 (which sits in column A) and see if that value exists in Sheet2 in either column A or column B. If it finds a match, it would need to copy the corresponding weight to column C on Sheet2.
I am a novice at writing macros and I've attached a modified version of code posted to a similar problem. Any help would be greatly appreciated - thank you in advance to any replies.
Sub CopyCells()
Application.ScreenUpdating = False
Dim sh1 As Worksheet, sh2 As Worksheet
Dim j As Long, i As Long, lastrow1 As Long, lastrow2 As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lastrow1 = sh1.Cells(Rows.Count, "A").End(xlUp).Row
lastrow2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow1
For j = 2 To lastrow2
If sh1.Cells(i, "A").Value = sh2.Cells(j, "A").Value Or _
sh1.Cells(i, "A").Value = sh2.Cells(j, "B").Value Then
sh1.Cells(i, "B").Value = sh2.Cells(j, "C").Value
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
This might help get you started. I am assuming you have data starting in row 1 in columns A and B of Sheet1 and Sheet2 and that you want to copy weights to Column C in Sheet2 :
Sub GetMatches()
Dim PartRngSheet1 As Range, PartRngSheet2 As Range
Dim lastRowSheet1 As Long, lastRowSheet2 As Long
Dim cl As Range, rng As Range
lastRowSheet1 = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
Set PartRngSheet1 = Worksheets("Sheet1").Range("A1:A" & lastRowSheet1)
lastRowSheet2 = Worksheets("Sheet2").Range("B65536").End(xlUp).Row
Set PartRngSheet2 = Worksheets("Sheet2").Range("A1:A" & lastRowSheet2)
For Each cl In PartRngSheet1
For Each rng In PartRngSheet2
If (cl = rng) Or (cl = rng.Offset(0, 1)) Then
rng.Offset(0, 2) = cl.Offset(0, 1)
End If
Next rng
Next cl
End Sub
Related
So I have an excel sheet where I want to loop through Sheet1 and find data pairs similar to Sheet2. So, I have for example A1:B1 and I need to find a row on Sheet2 that has exactly the same values next to each other (but it could be A33:B33 or anywhere) and copy the row over to Sheet1 (in column C or anything)
I am also trying to make it a dynamic loop so it checks for A1:B1 pair against Sheet2 then A2:B2 and so on until the last row.
Now the code I have only checks if A1:B1 on Sheet1 matches A1:B1 on Sheet2 (but not anywhere on the sheet). Also, I cannot make it so that it dynamically checks against every row on Sheet1 (I tried to make it with the x = x + 1 but it doesn't work)
Here is my code:
Sub matchme()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim r As Range
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
r = lastrow = sh1.Range("A" & Rows.Count).End(xlUp).Row
For x = 1 To r
If sh1.Range("A" & x) = sh2.Range("A" & x) And sh1.Range("B" & x) = sh1.Range("A" & x) & sh2.Range("B" & x) Then
sh1.Range("A" & x).EntireRow.Copy Destination:=sh2.Range("C" & x)
x = x + 1
Next x
End Sub
Please help, I have been struggling with this for days now and I need to hand in a report by the end of today, and I just cannot find anything helpful on the internet. I really appreciate any advice
If You want to use loops, try that:
Sub matchme()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim x As Long
Dim i As Long
Dim j As Long
Dim lastrow As Long
Dim lastRow2 As Long
Dim lastCol2 As Long
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
lastrow = sh1.Range("A" & Rows.Count).End(xlUp).Row
With sh2
lastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
lastCol2 = .Cells(1, Columns.Count).End(xlUp).Column
End With
For x = 1 To lastrow
For i = 1 To lastRow2
For j = 1 To lastCol2
If sh1.Cells(x, 1) = sh2.Cells(i, j) Then
If sh1.Cells(x, 2) = sh2.Cells(i, j + 1) Then
MsgBox "Found match!"
End If
End If
Next j
Next i
Next x
End Sub
I haven't tested this.
I've assumed you are searching for sheet1 A values in sheet2 column A only.
When a match is found, the column C value on sheet2 is copied to column C on sheet1.
Sub x()
Dim rFind As Range, s As String, r As Range
With Sheet1
For Each r In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
Set rFind = Sheet2.Columns(1).Find(What:=r.Value, Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind Is Nothing Then
s = rFind.Address
Do
If rFind.Offset(, 1).Value = r.Offset(, 1).Value Then
r.Offset(, 2).Value = rFind.Offset(, 2).Value
End If
Set rFind = Sheet2.Columns(1).FindNext(rFind)
Loop While rFind.Address <> s
End If
Next r
End With
End Sub
To get the pairs of Sheet1 and look for them in Sheet2:
I've used this code:
Application.ScreenUpdating = False
Dim i As Long
Dim LastRow As Long
Dim rng As Range
Dim wk1 As Worksheet
Dim wk2 As Worksheet
Dim SearchThis As String
Set wk1 = ThisWorkbook.Worksheets("Sheet1")
Set wk2 = ThisWorkbook.Worksheets("Sheet2")
LastRow = wk1.Range("A" & wk1.Rows.Count).End(xlUp).Row
'<--------------------------------->
'For more type of SPECIAL CELLS, and choose exactly the type you need
'please read https://learn.microsoft.com/en-us/office/vba/api/excel.range.specialcells
For i = 1 To LastRow Step 1
SearchThis = UCase(wk1.Range("A" & i).Value & wk1.Range("B" & i).Value)
For Each rng In wk2.Cells.SpecialCells(xlCellTypeConstants, 23)
If UCase(rng.Value & rng.Offset(0, 1).Value) = SearchThis Then
'code to copy where you want
Debug.Print rng.Row
End If
Next rng
Next i
Set wk1 = Nothing
Set wk2 = Nothing
Application.ScreenUpdating = True
The output of this code is:
Those are the row numbers where the pairs are. You just need to add a code to copy the entire row.
Hope this helps
Try below code (comments in code):
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim r As Range
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
lastRow = sh1.Range("A" & Rows.Count).End(xlUp).Row
iLastRow = sh2.Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To lastRow
For i = 1 To iLastRow
If sh1.Cells(j, 1) = sh2.Cells(i, 1) And sh1.Cells(j, 2) = sh2.Cells(i, 2) Then
sh1.Cells(i, 3) = "Write some information"
End If
'you don't need to increment loop variable "Next" does it for you
'also i is better suited for iterator name :)
Next
Next
I have a workbook with a series of sheets that I need to run a code to resolve the data.
I have one worksheet with a list of "codes" and another sheet that has cells that will include a string of codes.
I am trying to create a macro that allows me to reference a code in sheet1 A1, and then look through B:B in sheet2 and copy the row if the code appears in the string
I am a novice VBA user and have tried googling a few things and I'm not having any luck.
Edit:
I have managed to get something that does copy the data through, but there seems to be an issue in the For loop as all lines are copied in, not just the lines that match. Code below.
Private Sub CommandButton1_Click()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("MASTER LIST").UsedRange.Rows.Count
J = Worksheets("VALIDATED LIST").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("VALIDATED LIST").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("MASTER LIST").Range("E1:E" & I)
On Error Resume Next
Application.ScreenUpdating = True
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = InStr(Worksheets("MASTER LIST").Range("E1:E" & I).Value, Worksheets("TRANSPOSED DATA NO SPACES").Range("B1:B" & J)) > 1 Then
xRg(K).EntireRow.Copy Destination:=Worksheets("VALIDATED LIST").Range("A" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Further Edit:
I want to be able to use the list of feature codes and look them up in the master list.
If the VBA code finds the feature code in the strings in the master list, then I need to copy the row and paste it into a blank sheet that will be called validated list.
Sub look_up_copy()
Dim last_row As Integer
Dim cell As Range
Dim Cells As Range
last_row = ThisWorkbook.Worksheets(2).Cells(ThisWorkbook.Worksheets(2).Rows.Count, "B").End(xlUp).Row
Set Cells = ThisWorkbook.Worksheets(2).Range("B1:B" & last_row)
For Each cell In Cells:
If cell.Value = ThisWorkbook.Worksheets(1).Range("A1").Value Then
cell.EntireRow.Copy
End If
Next cell
End Sub
You didn't say anything about wanting to paste, but if you do then just insert it after the copy line.
this should work, just remove duplicates on sheet3 after running. This is a double loop in which, for each cell in column B of sheet 2, the macro will check all values from sheet1 Column A. You will see duplicate lines in the end, but it doesn't matter right? all you need is remove dupes
Sub IvanAceRows()
Dim cell2 As Range, cells2 As Range, cell1 As Range, cells1 As Range
Dim lastrow2 As Long, lastrow1 As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim i As Long, ii As Long, iii As Long
Set ws1 = Worksheets("USAGE CODES")
Set ws2 = Worksheets("MASTER LIST")
Set ws3 = Worksheets("VALIDATED LIST")
lastrow1 = ws1.cells(Rows.Count, 1).End(xlUp).Row
lastrow2 = ws2.cells(Rows.Count, 2).End(xlUp).Row
Set cells1 = ws1.Range("A1:A" & lastrow1)
Set cells2 = ws2.Range("B1:B" & lastrow2)
iii = 1
For ii = 1 To lastrow2
For i = 1 To lastrow1
If InStr(1, ws2.cells(ii, 2), ws1.cells(i, 1)) <> 0 Then
ws2.cells(ii, 2).EntireRow.Copy
ws3.Activate
ws3.cells(iii, 1).Select
Selection.PasteSpecial
iii = iii + 1
End If
Next i
Next ii
End Sub
Without seeing your spreadsheet, I assumed all of your 'codes' are listed in Column A in sheet1, and all of those code strings are also in sheet2 in column B. my code allows u to find each string from sheet1 in Column B of sheet2. Once found, it will be pasted into Sheet3 starting from the 2nd row.
Sub IvanfindsRow()
Dim i As Long
Dim lastrow1 As Long
Dim lastrow2 As Long
Dim Code As String
Dim search As Range
lastrow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
lastrow2 = Worksheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row
Worksheets("Sheet3").Range("A1").Select
For i = 1 To lastrow1
Code = Worksheets("Sheet1").Cells(i, 1).Value
Set search = Worksheets("Sheet2").Range("B1:B22").Find(what:=Code, lookat:=xlWhole)
If Not search Is Nothing Then
search.EntireRow.Copy
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial
Else 'do nothing
End If
Next i
Application.CutCopyMode = False
End Sub
I'm trying to figure out how to write compare code. I have two sheets', sheet1 and sheet2.
in sheet1 have five digits id numbers in column A, in sheet2 have same five digits id number in column C, but in sheet2 the id number is not the same row as column A in sheet1, they are differents row.
I'm trying to figure out how to make comparisons in sheet1 column A to search for a match in ANY row in sheet2 column B then copy the value from the same row in sheet2 Column C to sheet1 column D!
this is my own testing code but is not working.
Sub FindStuff()
Dim lr As Long
Dim i As Integer
lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lr
If UCase(Sheet2.Cells(1, 3).Value) = UCase(Sheet1.Cells(i, 1).Value) Then
Sheet2.Cells(14, 5).Value = Sheet1.Cells(i, 1).Offset(, 5).Value
End If
Next i
End Sub
The code you post has both syntax error and logic error, I'm not sure exactly what you are trying to do. Can you post an workbook example?
I changed your formula with Vlookup in the code, you can test and let me know if this is what you need.
Sub MatchValues()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr As Long
Dim r As Long
Application.ScreenUpdating = False
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
lr = ws2.Cells(Rows.Count, 3).End(xlUp).Row
For r = 2 To lr
On Error Resume Next
Cells(r, 4) = WorksheetFunction.VLookup(ws2.Cells(r, 3).Value, _
ws1.Range("A:A"), 1, 0)
Next
Application.ScreenUpdating = True
End Sub
This is my sheet 1 (source data);
sheet 1 = source (ws1)
I need to "copy" only the rows, where entire rows in the range A7:C1009 are not blank. This selection should then be entered in my sheet 2 (destination) starting from A7 in the table;
sheet 2 = destination (ws2)
I have managed to get this VBA working, but it will include all rows (menaing also the rows, where A:C are all blank/empty;
Private Sub CommandButton1_Click()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim cl1 As Range, rng1 As Range, rng2 As Range, rng3 As Range
Dim r As Long, c As Long
Set ws1 = Worksheets("Indkøb") 'Indkøb
Set ws2 = Worksheets("Kalkulation3") 'Kalkulation3
Set rng1 = ws1.Range("a7:a1009")
Set rng2 = ws1.Range("b7:b1009")
Set rng3 = ws1.Range("c7:c1009")
For Each cl1 In rng1
r = cl1.Row
c = cl1.Column
If cl1.Value <> ws2.Cells(r, c).Value Then
ws2.Cells(r, c).EntireRow.Insert
ws2.Cells(r, c).Value = cl1.Value
End If
Next cl1
For Each cl1 In rng2
r = cl1.Row
c = cl1.Column
If cl1.Value <> ws2.Cells(r, c).Value Then
ws2.Cells(r, c).Value = cl1.Value
End If
Next cl1
For Each cl1 In rng3
r = cl1.Row
c = cl1.Column
If cl1.Value <> ws2.Cells(r, c).Value Then
ws2.Cells(r, c).Value = cl1.Value
End If
Next cl1
End Sub
This is what I want to accomplish;
Only rows where A:C are not empty should be copied from sheet 1 and inserted in the table in sheet 2.
If more rows are added in sheet 1, running the macro again should insert the rows in the table in sheet 2 and move the existing rows - ie. if I insert rows 20 and 21 in sheet 1, row 21 should be copied and inserted as the "new" 8th row in the table in sheet 2, moving all other values/formulas below 8th row 1 down.
Any input on how to get this working would be greatly appreciated. Thank you :-)
This will accomplish what you want for your #1 request. You will need a different macro to accomplish your #2 request. Sorry, I can't help you with that.
Dim lRow As Long
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 7 To lRow
If IsEmpty(Cells(i, 1)) And IsEmpty(Cells(i, 2)) And IsEmpty(Cells(i, 3)) Then
Rows(i).EntireRow.Hidden = True
End If
Next i
Dim Rng As Range
Set Rng = ActiveSheet.Cells.SpecialCells(xlCellTypeVisible)
Rng.Copy Destination:=Sheets("Sheet2").Range("A7")
I review Stack Overflow almost daily to improve my VBA capabilities, when I find an interesting question, I try to construct a macro that will accomplish the task.
My code below does what I want, it loops through Sheet2, column "K" and searches for a match in Sheet1, column "A".
When a match is found, the code selects the cell in Sheet2, column "K", resizes 5 cells to the right and copies the range to a blank Sheet3, Column A.
To get each range to paste into a new row on Sheet3, I had to add an .Offset(1) on the Destination:= line.
Without the Offset the code just overwrites the data on row 1.
But, using the Offset the code starts writing the data on row 2.
My cheep fix was to just delete row 1.
I'm stuck, is there a way to fix my code, so it starts pasting the range of data on row 1?
Code is below;
Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Set ws3 = ThisWorkbook.Sheets("Sheet3")
Dim lRow1 As Long, lRow2 As Long, i As Long, j As Long
lRow1 = ThisWorkbook.Sheets("Sheet2").Range("K" & Rows.Count).End(xlUp).Row
lRow2 = ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lRow1
For j = 1 To lRow2
If ws2.Cells(i, 11).Value = ws1.Cells(j, 1).Value Then
'The part below does what I want it to do, except it skips row 1.
'If I remove the "Offset.(1)" it just overwrites the data in row 1.
ws2.Cells(i, 11).Resize(, 5).Copy Destination:=ws3.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next j
Next i
ws3.Rows(1).Delete 'My cheep fix is to delete row 1, which is blank, to get the data to start on row 1.
End Sub
Just encase anyone want to know how I resolved my issue.
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim r As Integer
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Set ws3 = ThisWorkbook.Sheets("Sheet3")
Dim lRow1 As Long, lRow2 As Long, i As Long, j As Long
lRow1 = ThisWorkbook.Sheets("Sheet2").Range("K" & Rows.Count).End(xlUp).Row
lRow2 = ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
r = 1
For i = 1 To lRow1
For j = 1 To lRow2
If ws2.Cells(i, 11).Value = ws1.Cells(j, 1).Value Then
ws2.Cells(i, 11).Resize(, 5).Copy Destination:=ws3.Cells(r, 1)
r = r + 1
End If
Next j
Next i