Please find below-
This may be done in a better way; but my knowledge is limited. Request reviews from expert members
Option Explicit
Dim ay As Long
Dim iCntr As Long
Sub Assume()
Dim ws As Worksheet
Dim r As Range
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name = "Combined" Then
Sheets("Combined").Delete
End If
Next
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Combined"
ay = 1
For Each ws In Worksheets
If ws.Name <> "Combined" Then
If ws.Index = 1 Then
Set r = ws.Range("A1").CurrentRegion
r.Copy Sheets("combined").Cells(ay, 1)
Else
Set r = ws.Range("A1").CurrentRegion
Set r = r.Offset(1, 0).Resize(r.Rows.Count - 1)
r.Copy Sheets("combined").Cells(ay, 1)
End If
ay = Sheets("Combined").Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
Next
Call FindDuplicatesInColumn
Call RemoveDuplicates
Application.DisplayAlerts = True
End Sub
Sub FindDuplicatesInColumn()
Dim matchFoundIndex As Long
ay = Sheets("Combined").Cells(Rows.Count, 1).End(xlUp).Row
For iCntr = 1 To ay
If Cells(iCntr, 2) <> "" Then
matchFoundIndex = WorksheetFunction.CountIf(Range("B1:B" & ay), Cells(iCntr, 2))
If matchFoundIndex > 1 Then
Cells(iCntr, 6) = "Duplicate"
End If
End If
Next
End Sub
Sub RemoveDuplicates()
With Sheets("Combined")
For iCntr = ay To 2 Step -1
If Cells(iCntr, 6) = "Duplicate" Then Rows(iCntr).Delete
Next
For iCntr = 1 To .UsedRange.Columns.Count
Columns(iCntr).EntireColumn.AutoFit
Next iCntr
End With
End Sub