Hi,
I finally have it worked with further edit. It copies all formats and works fine in xl 2003 but not in xl 2002 where it can't copy rows that have some special formats and styles in certain worksheets.
Sub Test()
Dim lastcol As Integer, lastrw As Long, lastcolumn As Integer, i As Long, j As Long, k As Long
Dim ws As Worksheet, FindSht As Worksheet, vFind, rSearch As Range
Dim rFound As Range, rFoundRow As Long, FirstAddress As String, NextAddress As String
Dim rNextFoundRow As Long
Sheets("Find").Activate
Set FindSht = Sheets("Find")
FindSht.Range(Cells(2, 2), Cells(3456, 22)).ClearContents
FindSht.Range(Cells(2, 2), Cells(3456, 22)).ClearFormats
lastcol = FindSht.Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, _
SearchDirection:=xlPrevious).EntireColumn.Column
lastrw = FindSht.Cells(FindSht.Rows.Count, "A").End(xlUp).Row
k = 1
j = 1
For i = 2 To lastrw
vFind = FindSht.Cells(i, 1)
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> FindSht.Name Then
Application.ScreenUpdating = False
ws.Activate
Set rSearch = ws.Range("I9:I" & Cells(65536, 9).End(xlUp).Row)
Set rFound = rSearch.Find(What:=vFind, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rFound Is Nothing Then
FirstAddress = rFound.Address
rFoundRow = rFound.Row
NextAddress = ""
j = j + 1
k = k + 1
Do While Not rFound Is Nothing And rFound.Address <> NextAddress
ws.Range("F" & rFoundRow & ":R" & rFoundRow & "").Copy FindSht.Cells(k, "H")
FindSht.Cells(j, "B").Value = ws.Name
ws.Range("A" & rFoundRow).End(xlUp).Resize(1, 5).Copy FindSht.Cells(j, "C")
ws.Range("S" & rFoundRow).End(xlUp).Copy FindSht.Cells(j, "U")
Set rFound = rSearch.FindNext(rFound)
NextAddress = rFound.Address
rNextFoundRow = rFound.Row
If (NextAddress <> FirstAddress) Then
j = j + 1
k = k + 1
ws.Range("F" & rNextFoundRow & ":R" & rNextFoundRow & "").Copy FindSht.Cells(k, "H")
FindSht.Cells(j, "B").Value = ws.Name
ws.Range("A" & rNextFoundRow).End(xlUp).Resize(1, 5).Copy FindSht.Cells(j, "C")
ws.Range("S" & rNextFoundRow).End(xlUp).Copy FindSht.Cells(j, "U")
End If
Loop
End If
End If
Next ws
Next i
'Undo the last selection for copying
Application.CutCopyMode = False
FindSht.Activate
Range("A2").Select
Application.ScreenUpdating = True
Set rFound = Nothing
Set rSearch = Nothing
Set FindSht = Nothing
End Sub