Traverse Multiple Sheets and Copy Unique Data to Summary

dqzk610 

Here you go:

Sub CopySubmittedRecords()
    Dim wss As Worksheet
    Dim wst As Worksheet
    Dim t As Long
    Dim rng As Range
    Dim adr As String
    Application.ScreenUpdating = False
    Set wst = Worksheets("Tracking")
    t = wst.Range("A" & wst.Rows.Count).End(xlUp).Row
    For Each wss In Worksheets(Array("Exterior", "Interior"))
        With wss.Range("E:E")
            Set rng = .Find(What:="Submitted", LookAt:=xlWhole)
            If Not rng Is Nothing Then
                adr = rng.Address
                Do
                    If wst.Range("A:A").Find(What:=rng.Offset(0, -4).Value, LookAt:=xlWhole) Is Nothing Then
                        t = t + 1
                        wst.Range("A" & t).Resize(1, 5).Value = rng.Offset(0, -4).Resize(1, 5).Value
                        If Not IsNumeric(wst.Range("F" & t - 1).Value) Then
                             wst.Range("F" & t).Value = 5000 ' or whichever starting number you prefer
                       Else
                            wst.Range("F" & t).Value = wst.Range("F" & t - 1).Value + 1
                        End If
                    End If
                    Set rng = .FindNext(After:=rng)
                    If rng Is Nothing Then Exit Do
                Loop Until rng.Address = adr
            End If
        End With
    Next wss
    Application.ScreenUpdating = True
End Sub