Snasui Excel Forum

Code: Select all

Sub Compare_Data()
    Dim iCount As Integer, rCount As Integer
    Dim j As Integer, rAll As Range
    Dim r As Range, lMatch As Long
    With Sheets("Data")
        Set rAll = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
        rCount = rAll.Count
        For j = rCount To 2 Step -1
            iCount = Application.CountIf(Sheets("Database").Columns(1), rAll(j))
            If iCount > 0 Then
                rAll(j).Resize(10).EntireRow.Insert
            End If
        Next j
        Set rAll = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)) _
            .SpecialCells(xlCellTypeConstants)
        For Each r In rAll
            iCount = Application.CountIf(Sheets("Database").Columns(1), r)
            If iCount > 0 Then
                lMatch = Application.Match(r, Sheets("Database").Columns(1), 0)
                r.Offset(0, 1).Resize(iCount) = Sheets("Database") _
                    .Range("b" & lMatch).Resize(iCount).Value
            End If
        Next r
        .Range("b2", .Range("b" & .Rows.Count).End(xlUp)) _
            .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
End Sub