Sheet sort ready for PDF export!

[eddy]

P/No Desc. Price PriceIncVAT Catagory
ColB ColC ColF ColG ColK

453 Resist 10.00 11.75 MAIN
454 Resist 14.00 16.45 MAIN
573 Cap1 2.00 2.35 CPU
574 Cap2 4.00 4.7 CPU

I have a spreadsheet which contains information in the columns as shown above(in Main sheet). I need a macro which will sort the sheet and produce output in the following format suitable for export to a PDF file.The MAIN sheet contains up to 500 items (lines).

MAIN
453 Resist 10.00 11.75
454 Resist 14.00 16.45
CPU
573 Cap1 2.00 2.35
574 Cap2 4.00 4.7
etc. etc
All help appreciated Ted

[Tom Schreiner]

Hi Ted.
I recieved your email about your new adjustment to Materquote.
I have not had enough time to really take a good look at it.
Would an export to a simple text file be good enough? I'm pretty sure you can open text files in Acrobat.
Let me know.
If so, I will paste the code here.
Thanks,
Tom

[eddy]

Thanks Tom! Yes that would be fine. The ultimate aim is to get an export into a PDF file (sample pdf can be seen at http://www.mkccomputers.co.uk) Thanks Ted

[Tom Schreiner]

Hi Ted
Here is code for your export.

Sub PDF_Export()

Dim HeaderText(), HeaderRow(), RowCntr As Long, NewElement As Integer, sp As Worksheet

RowCntr = 18

With Sheets("Main")

    ReDim HeaderText(1 To 1): ReDim HeaderRow(1 To 1)

    HeaderText(1) = .Cells(RowCntr, 12).Value

    HeaderRow(1) = RowCntr

    Do Until .Cells(RowCntr, 12) = ""

        If .Cells(RowCntr, 12) <> HeaderText(UBound(HeaderText)) Then

            NewElement = UBound(HeaderText) + 1

            ReDim Preserve HeaderText(1 To NewElement)

            ReDim Preserve HeaderRow(1 To NewElement)

            HeaderText(NewElement) = .Cells(RowCntr, 12)

            HeaderRow(NewElement) = RowCntr

        End If

        RowCntr = RowCntr + 1

    Loop

    NewElement = UBound(HeaderText) + 1

    ReDim Preserve HeaderRow(1 To NewElement)

    HeaderRow(NewElement) = RowCntr

    Set sp = Sheets("PDF_Dump")

    With sp.Range("C4:F5000")

        .ClearContents

        Application.ScreenUpdating = False

        .Font.Bold = False

        .Rows.RowHeight = 15.75

        .Font.Name = "Arial"

        .Font.Size = 12

    End With

    For NewElement = 1 To UBound(HeaderText)

        For RowCntr = HeaderRow(NewElement) To HeaderRow(NewElement + 1) - 1

            sp.Cells(RowCntr - 14, 3) = .Cells(RowCntr, 2)

            sp.Cells(RowCntr - 14, 5) = .Cells(RowCntr, 3)

            sp.Cells(RowCntr - 14, 6) = .Cells(RowCntr, 6)

        Next

    Next

    RowCntr = 0

    For NewElement = 1 To UBound(HeaderText)

        RowCntr = RowCntr + 1

        Rows(HeaderRow(NewElement) - 14).Insert Shift:=xlDown

        sp.Cells(HeaderRow(NewElement) - 14, 5) = "    " & HeaderText(NewElement)

        sp.Cells(HeaderRow(NewElement) - 14, 5).Font.Bold = True

        sp.Cells(HeaderRow(NewElement) - 14, 5).Font.Size = 14

        HeaderRow(NewElement + 1) = HeaderRow(NewElement + 1) + RowCntr

    Next

End With

Application.ScreenUpdating = True

Set sp = Nothing

End Sub

Tom