Insert header , hide rows and insert page breaks

Hi dwx

This Code is in the attached and appears to do as you require

Option Explicit
' Adapted From http://www.excelforum.com/excel-programming-vba-macros/846098-macro-to-take-data-from-sht1-and-rearrange-on-sht2.html?p=2867102
Sub Do_Me()
    Dim ws As Worksheet, ws1 As Worksheet
    Dim lLoop As Long, i As Long
    Dim rFoundCell As Range
    Dim myRegion As String, myStart As String
    Dim myHeads As Variant, myStyle As Variant

    myStyle = Array("xlEdgeLeft", "xlEdgeTop", "xlEdgeRight", "xlEdgeBottom")

    Set ws = Sheets("Original")
    Application.ScreenUpdating = False

    If Not Evaluate("ISREF(Desired!A1)") Then
        Worksheets.Add(After:=Sheets(1)).Name = "Desired"
    Else
        Sheets("Desired").Cells.Clear
    End If

    Set ws1 = Sheets("Desired")

    ws.Cells.Copy ws1.Range("A1")
    With ws1
        .Cells.EntireRow.Hidden = False
        myHeads = .Range("A4:B5")
        With Columns(1)
            Set rFoundCell = .Cells(1, 1)
            For lLoop = 1 To WorksheetFunction.CountIf(.Cells, "Name:")
                Set rFoundCell = .Find(What:="Name:", After:=rFoundCell, _
                        LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, MatchCase:=False)
                myRegion = rFoundCell.CurrentRegion.Address(True, True)
                myStart = Split(myRegion, ":")(0)
                If Not .Range(myStart).Offset(-2, 0).Value = "Date edited:" Then
                    .Range(myStart).Offset(-2, 0).Resize(2, 1).EntireRow.Insert
                    .Range(myStart).Offset(-1, 0).Resize(2, 2).Value = myHeads
                    For i = LBound(myStyle) To UBound(myStyle)
                        With .Range(myStart).Offset(-1, 0).Resize(2, 4).Borders
                            .LineStyle = xlContinuous
                            .Weight = xlMedium
                        End With
                    Next i
                    .Range(myStart).Offset(-1, 0).Resize(2, 4).Borders(xlInsideVertical).LineStyle = xlNone
                    .Range(myStart).Offset(-1, 0).Resize(2, 4).Borders(xlInsideHorizontal).LineStyle = xlNone
                End If
            Next lLoop
        End With

        With Columns(1)
            Set rFoundCell = .Cells(1, 1)
            For lLoop = 1 To WorksheetFunction.CountIf(.Cells, "Binary PW")
                Set rFoundCell = .Find(What:="Binary PW", After:=rFoundCell, _
                        LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, MatchCase:=False)
                myRegion = rFoundCell.CurrentRegion.Address(True, True)
                .Range(myRegion).EntireRow.Hidden = True
            Next lLoop
        End With
    End With
    Call PageBreaks
    Application.ScreenUpdating = True
End Sub

and

'From http://www.vbaexpress.com/kb/getarticle.php?kb_id=180
Sub PageBreaks()
    Dim ws1 As Worksheet
    Dim LR As Long
    Dim c As Range
    Dim FirstAddress As String, Search As String

    Set ws1 = Sheets("Desired")
    With ws1
        LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row
        .ResetAllPageBreaks
    End With
    With ws1.PageSetup
        .PrintArea = ""
        .PrintArea = "A4:D" & LR
    End With

    Search = "Company:"

    With ws1.Columns(1)
        Set c = .Find(What:=Search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
        If Not c Is Nothing Then
            FirstAddress = c.Address
            Do
                On Error Resume Next
                ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=c
                On Error GoTo 0
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> FirstAddress
        End If
    End With
End Sub