VBA not taking column widths, borders, and conditional formatting from source WS to pdf

[juscuz419]

I have been working on this for two days and cannot get the formatting details to come through on the pdf being attached to an email. All of the data is there but it is useless without the formatting

Option Explicit

Sub CreateAndEmailPDF()
Dim wsSource As Worksheet, wsTemp As Worksheet
Dim selectedCells As Range, cell As Range
Dim tempRow As Long
Dim outlookApp As Object, outlookMail As Object
Dim emailAddresses As String
Dim pdfFilePath As String

' Set the source worksheet
Set wsSource = Worksheets("Training View")

' Prompt user to select cells in Column A
On Error Resume Next
Set selectedCells = Application.InputBox("Select cells in Column A", Type:=8)
On Error GoTo 0

If selectedCells Is Nothing Then Exit Sub ' Exit if no cells selected

' Add a temporary worksheet
Set wsTemp = Worksheets.Add
wsTemp.Name = "Training Data"

' Copy headers from H5:S5, skipping hidden columns (Q and R)
wsSource.Range("H5:P5").Copy
wsTemp.Range("C1").PasteSpecial Paste:=xlPasteAll
wsSource.Range("S5").Copy
wsTemp.Range("L1").PasteSpecial Paste:=xlPasteAll

' Retain column widths
Dim col As Long
For col = 8 To 17
If wsSource.Columns(col).Hidden = False Then
wsTemp.Columns(col - 7).ColumnWidth = wsSource.Columns(col).ColumnWidth
End If
Next col

' Set the initial row for data in the temp sheet
tempRow = 2

emailAddresses = ""
For Each cell In selectedCells
If cell.Column = 1 Then
' Collect email addresses from Column G
If emailAddresses = "" Then
emailAddresses = wsSource.Cells(cell.Row, 7).Value
Else
emailAddresses = emailAddresses & ";" & wsSource.Cells(cell.Row, 7).Value
End If

' Copy values and formatting from selected rows, ignoring hidden columns
wsTemp.Cells(tempRow, 1).Value = wsSource.Cells(cell.Row, 3).Value ' Column C
wsTemp.Cells(tempRow, 2).Value = wsSource.Cells(cell.Row, 1).Value ' Column A

wsSource.Range("H" & cell.Row & ":P" & cell.Row).Copy
wsTemp.Cells(tempRow, 3).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
wsSource.Range("S" & cell.Row).Copy
wsTemp.Cells(tempRow, 12).PasteSpecial Paste:=xlPasteValuesAndNumberFormats

tempRow = tempRow + 1
End If
Next cell

' Define the file path for the PDF
pdfFilePath = ThisWorkbook.Path & "\Training_Data.pdf"

' Fit sheet to one page width in landscape mode
With wsTemp.PageSetup
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With

' Export the temp sheet as a PDF
wsTemp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfFilePath, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

' Set up Outlook and create email
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)

With outlookMail
.To = emailAddresses
.Subject = "Training Data PDF"
.Body = "Attached is the Training Data PDF."
.Attachments.Add pdfFilePath
.Display ' Show email for user review
End With

' Delete the temp sheet
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True

' Clean up
Application.CutCopyMode = False
'MsgBox "PDF created and email draft is ready!"
End Sub

 

[6StringJazzer]

This code that you already have should be doing the job but is for columns H:Q. You could expand/replicate it to cover A and C.

Dim col As Long
For col = 8 To 17
   If wsSource.Columns(col).Hidden = False Then
      wsTemp.Columns(col - 7).ColumnWidth = wsSource.Columns(col).ColumnWidth
   End If
Next col

 

[juscuz419]

That part of the code is not working as expected. From the picture below, H is the first Header and data column out to q. Note the column width for the header for the second column does not match the data in the second row (OMA-2023-11123. And the header in the next to last column is wrapping text.

 

[6StringJazzer]

the column width for the header for the second column does not match the data in the second row

Are you sure the correspondence of columns is correct? The loop code says that columns A:J in the temp sheet should be the same width as H:Q in the source sheet. But you are showing me H:Q in the temp sheet. Do you have the indexes backwards?

Code is:

For col = 8 To 17
   If wsSource.Columns(col).Hidden = False Then
      wsTemp.Columns(col - 7).ColumnWidth = wsSource.Columns(col).ColumnWidth
   End If
Next col

Should code be:

For col = 8 To 17
   If wsSource.Columns(col).Hidden = False Then
      wsTemp.Columns(col).ColumnWidth = wsSource.Columns(col - 7).ColumnWidth
   End If
Next col

 

[juscuz419]

Applying that I get the following result. I have added the source columns at the bottom of the picture.

 

[juscuz419]

OK so I made a couple of changes and have everything except column widths working. The picture below is of the temp sheet. I'm just at a loss as to why it is not working.

 

[6StringJazzer]

You still have the wrong code to copy the widths. The code, the descriptions in your posts, and the last screen shot all say three different things.

Based on this latest screen shot in post #14, your code needs to be as follows. Regrettably I do not have a file for testing.

' Copy formatting from source columns H:P (8-16) to temp columns C:K (3-11)
For col = 8 To 16 ' destination 3-11
   If wsSource.Columns(col).Hidden = False Then
      wsTemp.Columns(col - 5).ColumnWidth = wsSource.Columns(col).ColumnWidth
   End If
Next col

' source column S (19), destination L (12)
If wsSource.Columns("S").Hidden = False Then
   wsTemp.Columns("L").ColumnWidth = wsSource.Columns("S").ColumnWidth
End If

 

[juscuz419]

Eureka! Thanks Jeff

 

[6StringJazzer]

If at first you don't succeed.....