As with all macros that change data, you should test the macro out on a
copied workbook to make sure it works the way you want and expect. The
reason? Changes to worksheets made by macros cannot be undone. Also, it is
important to note that if the names of any of your companies contain the
letters of what you called the "common companies", then they will also be
moved. For example, if you had a company named Federated Insurance Groups Of
America, this company name would be picked up as a UPS company because those
letters appear in the word "Groups" in its name. I might be able to trap for
this kind of misidentification, but it depends on where in the name the
"common companies" name part appears. For example, are these "common
company" name parts always separated from the rest of the name by a space?
If so, do they appear at the beginning, middle or end of the full company
name?
With these warnings in mind, give this macro a try (note that I assumed your
company names are in Column A; if this is wrong, change the column letter in
the Const statement)...
Sub MoveCommonCompaniesToTheEnd()
Dim X As Long
Dim MovedDataStartRow As Long
Dim R As Range
Dim ToMove As Range
Dim WS As Worksheet
Dim FirstAddress As String
Dim CompanyNames() As String
' Column to search for common company names
Const CompanyNamesRow As String = "A"
' Comma delimited list; no spaces around commas
Const Companies As String = "TNT,UPS,Fedex"
CompanyNames = Split(Companies, ",")
For Each WS In Worksheets
MovedDataStartRow = WS.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious).Row + 3
For X = 0 To UBound(CompanyNames)
Set ToMove = Nothing
Set R = WS.Columns(CompanyNamesRow).Find(What:=CompanyNames(X), _
After:=WS.Cells(WS.Rows.Count, CompanyNamesRow), _
LookAt:=xlPart, MatchCase:=False)
If Not R Is Nothing Then
FirstAddress = R.Address
Do
If ToMove Is Nothing Then
Set ToMove = R.EntireRow
Else
Set ToMove = Union(R.EntireRow, ToMove)
End If
Set R = WS.Columns(CompanyNamesRow).FindNext(R)
Loop While Not R Is Nothing And R.Address <> FirstAddress
ToMove.Copy WS.Cells(MovedDataStartRow, "A")
ToMove.Delete
MovedDataStartRow = WS.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious).Row + 1
End If
Next
Next
End Sub