Option Explicit
Const wb1 = "[COLOR=#ff0000]C:\FullPath\ToFile1\wb1.xlsx[/COLOR]"
Const c1 = "[COLOR=#ff0000]A[/COLOR]"
Const wb2 = "[COLOR=#000080]C:\FullPath\ToFile2\wb2.xlsx[/COLOR]"
Const c2 = "[COLOR=#000080]D[/COLOR]"
Const wb3 = "[COLOR=#008080]C:\FullPath\ToFile3\wb3.xlsx[/COLOR]"
Const c3 = "[COLOR=#008080]E[/COLOR]"
Dim a1, a2, a3, a
Dim wb As Workbook, ws As Worksheet, cel As Range, rng As Range
Sub CreateReport()
Application.ScreenUpdating = False
CreateArrays
ListAllRecords
ClearNoFlag
End Sub
Private Sub CreateArrays()
Set wb = Workbooks.Open(wb1)
With wb.Sheets(1)
a1 = .Range(.Cells(2, c1), .Cells(.Rows.Count, c1).End(xlUp))
End With
wb.Close False
Set wb = Workbooks.Open(wb2)
With wb.Sheets(1)
a2 = .Range(.Cells(2, c2), .Cells(.Rows.Count, c2).End(xlUp))
End With
wb.Close False
Set wb = Workbooks.Open(wb3)
With wb.Sheets(1)
a3 = .Range(.Cells(2, c3), .Cells(.Rows.Count, c3).End(xlUp))
End With
wb.Close
End Sub
Private Sub ListAllRecords()
Set wb = ThisWorkbook
Set ws = wb.Sheets.Add(before:=wb.Sheets(1))
With ws
'add headers
.Cells(1, 1) = "RECORDS"
.Cells(1, 2) = Right(wb1, Len(wb1) - InStrRev(wb1, "\"))
.Cells(1, 3) = Right(wb2, Len(wb2) - InStrRev(wb2, "\"))
.Cells(1, 4) = Right(wb3, Len(wb3) - InStrRev(wb3, "\"))
'add records
.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(a1)) = a1
.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(a2)) = a2
.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(a3)) = a3
Set rng = .Range(.Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
'remove duplicates
rng.RemoveDuplicates Columns:=1, Header:=xlYes
Set rng = .Range(.Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
'sort records
rng.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes
'add "No" flag
rng.Offset(1, 1).Resize(rng.Rows.Count - 1, 3).Value = "No"
End With
End Sub
Private Sub ClearNoFlag()
For Each cel In rng
For Each a In a1
If a = cel Then
cel.Offset(, 1).ClearContents
Exit For
End If
Next a
For Each a In a2
If a = cel Then
cel.Offset(, 2).ClearContents
Exit For
End If
Next a
For Each a In a3
If a = cel Then
cel.Offset(, 3).ClearContents
Exit For
End If
Next a
Next cel
End Sub