Well, assuming that you are ... this code is a bit hacky, but should do what you want.
However, it does assume that each shipment has "FRT" in the first row of the shipment info in column B - is this always the case?
Sub TransferInfo()
Const sSEARCH_FOR As String = "FRT"
Const lFIRST_HEADER_COL As Long = 5
Const lSEARCH_COL As Long = 2
Dim wshTarget As Worksheet
Dim wshSource As Worksheet
Dim rngMatch As Range
Dim rngWrite As Range
Dim vHeaders As Variant
Dim sFirst As String
vHeaders = Array("Freight discount amount", "Billed Freight", "Published charge", "Published fuel surcharge", "Billed fuel surcharge")
Set wshSource = ActiveSheet
'Create new workbook and add headers
Set wshTarget = Sheets.Add(after:=Sheets(Sheets.Count))
wshTarget.Cells(1, lFIRST_HEADER_COL).Resize(1, UBound(vHeaders) + (1 - LBound(vHeaders))).Value = vHeaders
Set rngWrite = wshTarget.Cells(2, 1)
Set rngMatch = wshSource.Columns(lSEARCH_COL).Find(sSEARCH_FOR, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True, after:=wshSource.Cells(Rows.Count, lSEARCH_COL).End(xlUp))
If Not rngMatch Is Nothing Then
sFirst = rngMatch.Address
Do
rngWrite.Resize(1, 4).Value = rngMatch.EntireRow.Cells(1).Resize(1, 4).Value
rngWrite.Offset(0, 4).Value = rngMatch.Offset(0, 8).Value
rngWrite.Offset(0, 5).Value = rngMatch.Offset(0, 9).Value
rngWrite.Offset(0, 6).Value = rngMatch.Offset(1, 5).Value
rngWrite.Offset(0, 7).Value = rngMatch.Offset(1, 8).Value
rngWrite.Offset(0, 8).Value = rngMatch.Offset(1, 9).Value
Set rngMatch = wshSource.Columns(lSEARCH_COL).FindNext(rngMatch)
Set rngWrite = rngWrite.Offset(1)
Loop Until rngMatch.Address = sFirst
End If
End Sub
Bookmarks