PLEASE HELP with Macro for Data Consolidation

[jakecc]

To whom it may concern,

Hello, my name is Jake, and today I'm working with a contact spreadsheet that is beyond my current skill set. I'm looking for help in writing a macro (I think that's what's needed). The command set is as follows:

Look at columns A, B, C, D, & E (Sheet1) and determine which rows within that column range are duplicates

For the corresponding rows that are a complete match (whereas all of the cells are identically matched within that column range of A through E)

Proceed to then look at columns F through AH (within the identified, duplicate rows)

If the corresponding rows are a match, delete all redundant rows (keep one)

Then, look at Sheet 1 again. For every row that is only populated with values in columns A through E and columns H through J, split off that row to sheet 3 (beginning on row 2 of sheet 3).

Would someone be so kind as to help me with this?

Thanks in advance!

Jake

 

[jakecc]

Guys?

 

[jakecc]

Any1?

 

[MrExcel]

I am assuming you have headers in Row 1, data starts in row 2. I've also assumed column AI on Sheet1 is blank to hold a temporary column.

Sub RemoveDuplicates()
    Dim WS1 As Worksheet
    Dim WS3 As Worksheet
    Set WS1 = Worksheets("Sheet1")
    Set WS3 = Worksheets("Sheet3")
    Dim IRange As Range
    Dim ORange As Range
    Dim CRange As Range
    ' Delete redundant rows where A:E and then F:AH are redundant
    WS1.Range("A1").CurrentRegion.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, _
        7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, _
        25, 26, 27, 28, 29, 30, 31, 32, 33, 34), Header:=xlYes
        
    ' If nothing is populated in K:AH, move to Sheet3
    WS1.Select
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range("AI1").Value = "Count"
    Range("AI2").Resize(FinalRow - 2, 1).Formula = "=COUNTA(K2:AH2)"
    WS3.Cells.Clear
    WS1.Range("A1:J1").Copy Destination:=WS3.Cells(1, 1)
    WS3.Range("L1").Value = "Count"
    WS3.Range("L2").Value = 0
    Set CRange = WS3.Range("L1:L2")
    Set IRange = WS1.Cells(1, 1).Resize(FinalRow, 35)
    Set ORange = WS3.Cells(1, 1).Resize(1, 10)
    IRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=CRange, CopyToRange:=ORange
    
    ' Delete the rows on Sheet1 that were just moved
    IRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=CRange
    IRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    WS1.ShowAllData
    
    ' Remove the criteria range on Sheet3 and the temp column in AI
    WS3.Range("L1:L2").ClearContents
    WS1.Columns(35).ClearContents
    
End Sub