Im trying to compare two sheets which is sheet1 and sheet2 and print values in sheet3. When i am comparing between sheet1 and sheet2 and looking for non matching numbers, somehow my loop doesn't stop and lots of time its printing the samenumber. Here is my code but is there any other ways i can find non matching numbers between two sheets and paste it into sheet3.
lastrow1 = Sheets("Sheet1").UsedRange.Row - 1 + Sheets("Sheet1").UsedRange.Rows.Count
lastrow2 = Sheets("Sheet2").UsedRange.Row - 1 + Sheets("Sheet2").UsedRange.Rows.Count
a = 1
b = 1
c = 1
For i = a To lastrow1
For ii = b To lastrow2
If Worksheets("Sheet1").Cells(i, 1) <> Worksheets("Sheet2").Cells(ii, 1) Then
Worksheets("Sheet3").Range("A" & x) = Worksheets("Sheet1").Cells(i, 1)
x = x + 1
End If
Next ii
Next i
Note: the below code checks column A in Sheet1 against column A in Sheet2. Then, the Main() calls the same code with a reverse order so all the numbers in Sheet2 in column A are checked against Sheet1 column A. If you only want to see the values that are in Sheet1 but not in Sheet2 comment out the second call to PrintNonMatching in Main()
Sub Main()
PrintNonMatching "Sheet1", "Sheet2", "Sheet3"
PrintNonMatching "Sheet2", "Sheet1", "Sheet3"
End Sub
Sub PrintNonMatching(arg1 As String, arg2 As String, arg3 As String)
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Set sh1 = Sheets(arg1): Set sh2 = Sheets(arg2): Set sh3 = Sheets(arg3)
Dim match As Boolean
For Each c1 In sh1.Range("A1:A" & sh1.Range("A" & Rows.Count).End(xlUp).Row)
For Each c2 In sh2.Range("A1:A" & sh2.Range("A" & Rows.Count).End(xlUp).Row)
If c1 = c2 Then match = True
Next
If Not match Then
sh3.Range("A" & sh3.Range("A" & Rows.Count).End(xlUp).Row + 1) = c1
End If
match = False
Next
End Sub
Related
I am trying to make the following to work:
There are two tables in a separate worksheets. I want it to check each cell in worksheet2 column B and find a match from worksheet1 column A. If a match is found then replace the data in worksheet2 column B with a data from a matching row of worksheet1 column B.
If a match is not found from a worksheet1 column A then delete entire row in a worksheet2 column B.
Sub match_repl_del()
Dim r1 As Long, rfound, vfound
Dim w1, w2, v As Long
Set w1 = Sheets(3) ' data sheet
Set w2 = Sheets(2) ' target sheet
r1 = 2 'data starting from row 2
Do While Not IsEmpty(w1.Cells(r1, 1))
v = w1.Cells(r1, 1)
rfound = Application.Match(v, w2.Columns(2), 0) ' look for value
If Not IsError(rfound) Then ' found it?
vfound = w2.Cells(rfound, 2)
If w1.Cells(r1, 2) <> vfound Then ' if value does not match sheet1 column b
w2.Cells(rfound, 2) = w1.Cells(r1, 2) ' update based on origin sheet
lastC = w2.Cells(rfound, 1).End(xlToRight).Column
w2.Range(w2.Cells(rfound, 1), w2.Cells(rfound, lastC)).Interior.ColorIndex = 5
Else ' delete entire row on sheet2 if match is not found
w2.Rows(r1).EntireRow.Delete
End If
End If
r1 = r1 + 1
Loop
End Sub
Try this wat, 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("Sheet1") 'find a match in worksheet1 column A
Set ws_2 = wb.Sheets("sheet2") 'cell in worksheet2 column B
'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 'if you need, adjust column to find last row
lastRow_ws2 = ws_2.Range("B" & Rows.Count).End(xlUp).Row 'if you need, adjust column to find last row
'*******************************************
For i = lastRow_ws2 To 2 Step -1
For j = 1 To lastRow_ws1
Dim keySearch As String
Dim keyFind As String
keySearch = ws_2.Cells(i, 2).Value
keyFind = ws_1.Cells(j, 1).Value
If keySearch = keyFind Then
'MsgBox keySearch & " " & keyFind & " yes"
ws_2.Cells(i, 2).Value = ws_1.Cells(j, 2).Value
GoTo next_i
End If
Next j
ws_2.Rows(i).EntireRow.Delete
next_i:
Next i
End Sub
I have a list in "Sheet1" with three Columns, A (Account Number), B (Description) & C (Amount). Based on 1st two columns (A & B) color, I want to copy the specific row to "Sheet2" and Paste it under one specific header (I have three headers).
Example
Sheet1 - Cell A2 is "Red" & B2 is "Yellow", Copy/Paste Under Header "Inefficiencies" in Sheet2
Sheet1 - Cell A3 is "Blue" & B3 is "No Color" Copy/Paste Under Header "Effective" in Sheet2
Account Number Description Amount
LP001022 Graduate 3,076.00
LP001031 Graduate 5,000.00
LP001035 Graduate 2,340.00
I have taken a code from this site already, but I could not completely configure it to my needs. Thank you for the help in advance.
Sub lastrow()
Dim lastrow As Long
Dim i As Long, j As Long
Dim acell As Range
With Worksheets("Sheet1")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
MsgBox (lastrow)
With Worksheets("Sheet3")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
For i = 1 To lastrow
With Worksheets("Sheet1")
If .Cells(i, 1).Interior.Color = RGB(255, 255, 0) And _
.Cells(i, 1).Interior.ColorIndex = xlNone Then
.Rows(i).Copy 'I have to give destination
j = j + 1
End If
End With
Next i
End Sub
Here are the key instructions to copy a row from sheet1 to INSERT into a row in sheet2. This assumes you have all the row numbers.
' -- to copy a row in sh1 to INSERT into sh2:
sh2.Rows(irowInefficiency + 1).Insert
sh1.Rows(irowFrom).Copy sh2.Rows(irowInefficiency + 1)
' -- you have to increment all header rows after this one
irowEffective = irowEffective + 1
The following puts these in context:
Sub sub1() ' copy/insert a row
Dim irowFrom&, irowInefficiency&, irowEffective&
Dim sh1, sh2 As Worksheet
Set sh1 = Sheets("sheet1")
Set sh2 = Sheets("sheet2")
irowInefficiency = 3 ' where that header is
irowEffective = 6 ' where that header is
irowFrom = 5 ' the row to copy
' -- to copy a row in sh1 to INSERT into sh2:
sh2.Rows(irowInefficiency + 1).Insert ' a blank row
sh1.Rows(irowFrom).Copy sh2.Rows(irowInefficiency + 1) ' then copy
' -- you have to increment all header rows after this one
irowEffective = irowEffective + 1 ' because it increases
End Sub
I want to screen all sheets for values that starts with "D"
In the sheets I formed blocks (1 column, 4 rows) with
- owner
- area
- parcel (that is allways starting with a "D")
- year of transaction (blocks of 1 column and 4 rows).
I want to make a summary in sheet "Test".
I'm able to find the parcel, but how can I get the info from the cell above?
Sub Zoek_kavels()
Dim ws As Worksheet
Dim rng As Range
Dim Area
Dim Kavel As String
rij = 1
For Each ws In ActiveWorkbook.Sheets
Set rng = ws.UsedRange
For Each cell In rng
If Left(cell.Value, 1) = "D" Then 'Starts with D
Sheets("Test").Cells(rij, 1) = cell.Value 'Kavel D..
Cells(cell.row - 1, cell.Column).Select
Area = ActiveCell.Value
Sheets("Test").Cells(rij, 2) = Area 'Oppervlakte
Sheets("Test").Cells(rij, 3) = ws.Name 'Werkblad naam
rij = rij + 1
End If
Next
Next
End Sub
A nice simple loop should do the trick, you may have had spaces in the worksheet, that would throw off the used range.
Here is a different approach.
Sub Get_CellAboveD()
Dim LstRw As Long, sh As Worksheet, rng As Range, c As Range, ws As Worksheet, r As Long
Set ws = Sheets("Test")
For Each sh In Sheets
If sh.Name <> ws.Name Then
With sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:A" & LstRw)
If LstRw > 1 Then
For Each c In rng.Cells
If Left(c, 1) = "D" Then
r = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
ws.Range("A" & r).Value = c
ws.Range("B" & r).Value = c.Offset(-1).Value
ws.Range("C" & r).Value = sh.Name
End If
Next c
End If
End With
End If
Next sh
End Sub
There are two important points (and two not so important) to take care of your code:
start from row 2, because you are using .row - 1. Thus, if you start at row 1, row-1 would throw an error;
try to avoid Select, ActiveCell, etc.;(How to avoid using Select in Excel VBA);
write comments in English, not in Dutch (also good idea for variable names as well, rij or kavel do not help a lot);
declare the type of your variables, e.g. dim Area as String or as Long or anything else;
Option Explicit
Sub ZoekKavels()
Dim ws As Worksheet
Dim rng As Range
Dim Kavel As String
Dim rij As Long
Dim cell As Range
rij = 2 'start from the second row to avoid errors in .Row-1
For Each ws In ActiveWorkbook.Worksheets
Set rng = ws.UsedRange
For Each cell In rng
If Left(cell, 1) = "D" Then
With Worksheets("Test")
.Cells(rij, 1) = cell
.Cells(rij, 2) = ws.Cells(cell.Row - 1, cell.Column)
.Cells(rij, 3) = ws.Name
End With
rij = rij + 1
End If
Next
Next
End Sub
Or you can use .Cells(rij, 2) = cell.Offset(-1, 0) instead of Cells(cell.Row - 1, cell.Column), as proposed in the comments by #Shai Rado.
I have two Sheets sheet1, sheet2
With sheet1 i have id which always starts with 4, I look for this ID in sheet2, and pul the corresponding names and copy back to sheet1.
The ID is always 8 Digit Long.
during this , I have an Special case, where an ID has some Special charachters and charachters. eg: 41017734_dr_bad ; the code Fails in this case. I doesnot recognise the first 8 and Fails to paste in the another sheet.
Could someone suggest how to overcome this?
I have an idea we could use whilcard and also strlen function. But struck how to use in code.
Sub match()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim cell As Range, cell2 As Range, lstcl As Variant, lstcl2 As Variant, rgFnd As Variant
Dim n As Double, ID As String
Set sh1 = ThisWorkbook.Sheets("S")
Set sh2 = ThisWorkbook.Sheets("P")
ID = "4"
lstcl = sh1.Range("N10000").End(xlUp).Row
lstcl2 = sh2.Range("L10000").End(xlUp).Row
'comparing columns N and L in both sheets
For Each cell In sh2.Range("L5:L" & lstcl2)
For n = 5 To lstcl
If cell = sh1.Range("N" & n) Then
'the cell in column M next to the matching cell is equal to the 4xxxxxxx number
cell.Offset(0, 1) = sh1.Range("N" & n)
'the next cell in column N is equal to the A2C number in column A
cell.Offset(0, 2) = cell.Offset(0, -11)
End If
Next
Next
'test that each cell in the first sheet corresponds to the located results in the second sheet _
'and pastes back the A2C number, using the Range.Find function
For Each cell2 In sh1.Range("N5:N" & lstcl)
If Left(cell2, 1) = ID Then
Set rgFnd = sh2.Range("M5:M" & lstcl2).Find(cell2.Value)
If Not rgFnd Is Nothing Then
cell2.Offset(0, 1) = sh2.Range(rgFnd.Address).Offset(0, 1)
End If
End If
Next
End Sub
Try this
Sub match()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim cell As Range, cell2 As Range, lstcl As Variant, lstcl2 As Variant, rgFnd As Variant
Dim n As Double, ID As String
Set sh1 = ThisWorkbook.sheets("S")
Set sh2 = ThisWorkbook.sheets("P")
ID = "4"
lstcl = sh1.Range("N10000").End(xlUp).Row
lstcl2 = sh2.Range("L10000").End(xlUp).Row
'comparing columns N and L in both sheets
For Each cell In sh2.Range("L5:L" & lstcl2)
For n = 5 To lstcl
a = Left(sh1.Range("N" & n), 8)
If cell = a Then
'the cell in column M next to the matching cell is equal to the 4xxxxxxx number
cell.Offset(0, 1) = a
'the next cell in column N is equal to the A2C number in column A
cell.Offset(0, 2) = cell.Offset(0, -11)
End If
Next
Next
'test that each cell in the first sheet corresponds to the located results in the second sheet _
'and pastes back the A2C number, using the Range.Find function
For Each cell2 In sh1.Range("N5:N" & lstcl)
If Left(cell2, 1) = ID Then
Set rgFnd = sh2.Range("M5:M" & lstcl2).Find(cell2.Value)
If Not rgFnd Is Nothing Then
cell2.Offset(0, 1) = sh2.Range(rgFnd.Address).Offset(0, 1)
End If
End If
Next
End Sub
I need to copy an entire row from a sheet and paste in another sheet with same header consider a particular column value is equal to 89581.But my VBA throws 424 error.Please help.
Sub CopyData()
Dim c As Range
Dim Row As Long
Dim sheetUse As Worksheet
Dim sheetCopy As Worksheet
Set sheetUse = Sheets("Data1").Select
Set sheetCopy = Sheets("Data2").Select
Row = 3 'Assume same header in sheet2 as in sheet1
For Each c In sheetUse.Range("O3", Sheet1.Range("O65536").End(xlUp))
If c = 89581 Then
'copy this row to sheet2
Row = Row + 1
c.EntireRow.Copy sheetCopy.Cells(Row, 1)
End If
Next c
Application.CutCopyMode = False
End Sub
Here you go, build a reference to copy then copy and paste in one go.
Sub CopyToOtherSheet()
Dim sheetUse As Worksheet, sheetCopy As Worksheet, i As Long, CopyRange As String
Set sheetUse = Sheets("Data1")
Set sheetCopy = Sheets("Data2")
For i = 3 To sheetUse.Cells(Rows.Count, 15).End(xlUp).Row
If sheetUse.Cells(i, 15) = 89581 Then CopyRange = CopyRange & "," & i & ":" & i
Next i
sheetUse.Range(Right(CopyRange, Len(CopyRange) - 1)).Copy
sheetCopy.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll 'Change to values or formats or whatever you want
Application.CutCopyMode = False
End Sub
Assumed Data1 is the sheet with the data in and Data2 is the one to copy to.