CODEWITHSUNDEEP
vbaexcel
Skylimit
Skylimit

Reputation: 39

VBA Delete rows of matching data

I built a macro that transfers 2 csv files of data on sheet 1 and sheet 2 and renames those 2 sheets. I want to build another macro that will copy all non-matching rows in between the 2 sets of data into a new xlsx file. To identify matching data, I need to write something that will do this:

If a cell value of column A in sheet1 has a matching value in column A of sheet2, then I need to compare for the corresponding rows on each sheet: Column B of sheet1 to Column C of sheet2, Column D of sheet1 to Column E of sheet2, Column F of sheet1 to Column G of sheet2, Column G of sheet1 to Column H of sheet2, Column H of sheet1 to Column I of sheet2, Column J of sheet1 to Column J of sheet2 and copy all rows of data in sheet1 that do not have matching rows in sheet2 into a new file.

Here is a draft of my code:

Sub SupprLignes()
Dim rowCount1 As Long, rowCount2 As Long
Dim rng1 As Range, rng2 As Range, MyCell As Range, Mycell2 As Range
Dim currentRow As Long
Dim WB As Workbook
Dim WS As Worksheet

Set WB = Workbooks.Add

ActiveWorkbook.SaveAs "C:\Users\Phil\Desktop _
\Report_" & Format(Date, "dd-mm-yyyy") & ".xlsx"

rowCount1 = Workbooks("Received_temp.xlsx").Worksheets _
("Received").Range("A2").SpecialCells(xlCellTypeLastCell).Row

Set rng1 = Workbooks("Received_temp.xlsx").Worksheets _
("Received").Range("A2:A" & rowCount1)

rowCount2 = Workbooks("Received_temp.xlsx").Worksheets _
("NotReceived").Range("A2").SpecialCells(xlCellTypeLastCell).Row
Set rng2 = Workbooks("Received.xlsx").Worksheets _
("NotReceived").Range("A2:A" & rowCount2)

Dim sheet1() As Variant
ReDim sheet1(rowCount1 - 1, 2)

currentRow = 0

For Each MyCell In rng1.Cells
    For Each Mycell2 In rng2.Cells
        If Mycell2.Value = MyCell.Value And Mycell2.Offset(0, 5).Value = _
MyCell.Offset(0, 5).Value And Mycell2.Offset(0, 2).Value = _
MyCell.Offset(0, 2).Value Then

            Workbooks("Received_temp.xlsx").Worksheets _
("Received").Rows(Cell.Row).Copy
                Destination:=Workbooks("Received.xlsx").Worksheets _
("Received").Range("A" & currentRow)

            currentRow = currentRow + 1

            GoTo NextIteration
        End If
    Next cell2
Next Cell

NextIteration:
ThisWorkbook.Sheets(1).Rows(Cell.Row).Copy Destination:=ThisWorkbook.Sheets(4).Range("A" & currentRow)

End Sub

I know the For Next is wrong but I knew I was not in the right direction so I let it like that for the moment.

Upvotes: 0

Views: 2481

Answers (1)

rgo
rgo

Reputation: 491

For starters add a column to the worksheet and insert the Match function. This will tell you the row number of the corresponding search value. #N/A's will appear for the non-matching rows. You can automate populating the Match column by using the macro recorder to save the formulas in RC format, then copy them down to the bottom of the sheet.

Now loop through the match row column looking for the #N/A's

Example:

Dim aCell as range
Dim aRange as range
dim tWS as worksheet
dim lrow as long

Application.calculation = xlmanual
set tWS = thisworkbook.sheets("Sheet2")  '*** Target worksheet to copy not founds

set arange = intersect(activesheet.range("A1"), activesheet.usedrange)
for each acell in arange
   if isnull(acell) then
     lrow = tws.range("A65536").end(xlup).row + 1
    copy acell.entirerow tws.range("A" & Lrow)
   endif
next acell
application.calculation = xlAutomatic

When done you can copy the TWS to another workbook, which is easier than linking to a new workbook and appending one record at a time.

Upvotes: 0

Related Questions