Use VBA to Export range to PDF and XLSX, ISSUE: not all Cell Names get copied, please HELP

Frequent Visitor

Hi i am stuck on a workbook.

Exporting works mostly. If anybody needs the code. you are welcome.

 

The remaining issue is that i have not been able to copy all cell names.

A few do get copied but others do not. i dont understand why? The value of the cell gets copied as expected. Why only some cellnames get copied, i have no clue.

 

Sofar i tried copy paste the sheet to a new WB by hand and the same issue exists.

i assume this is a general error in office.

 

The code below is able to export PDF, XLSX

 

 

 

 

 

Sub SaveAreaAsPDF()
  
  Dim CurrentWS  As Worksheet
  Dim strName, strPath, strFile, strFileExt, strPathFile As String
  Dim myFile As Variant

   On Error GoTo errHandler
  
  Application.ScreenUpdating = False
  
  '~~> Set the relevant sheet from where you want to copy
  Set CurrentWS = ThisWorkbook.ActiveSheet
  
  strPath = CurrentWS.Range("L2").Text
  If strPath = "" Then strPath = Application.ActiveWorkbook.Path
  strPath = strPath & "\Rechnungen\"
  
  '~~> check if the folder exists, if not create it
  If Dir(strPath, vbDirectory) = "" Then
   MsgBox "Neuer Ordner Erstellt " & vbCrLf & strPath, vbInformation
   MkDir strPath
  End If
  
  strName = CurrentWS.Range("A20").Text & " - " & CurrentWS.Range("D15").Value
  
  strName = Replace(strName, ".", "-")
  strName = Replace(strName, ",", " -")
  
     If strName = " - " Then
          MsgBox "Dateiname Leer" & vbCrLf & "Bitte A20 und D15 ausfüllen", vbCritical
        Exit Sub
    End If

    '~~>'create default name for saving file
    strFileExt = strName & ".pdf"
    strPathFile = strPath & strFileExt
   

        '~~> check if the file is open
        If IsFileOpen(strPathFile) = True Then
            MsgBox "Die Datei ist geöffnet, bitte schliessen Sie." & vbCrLf & strPath & vbCrLf & strName, vbInformation
            Exit Sub
        End If
         
         '~~> check if the file exists
         If Dir(strPathFile) <> "" Then
        MsgBox "Datei bereits vorhanden " & vbCrLf & strPath & vbCrLf & strName, vbInformation
        
        '~~> user can enter name and select folder for file
        myFile = Application.GetSaveAsFilename(InitialFileName:=strPathFile, FileFilter:="PDF Dateien (*.pdf), *.pdf", Title:="Datei speichern unter")
        
        If myFile = 0 Then
            Exit Sub
        Else
            strPathFile = myFile
       End If
    End If

  
   '~~> Hide Emptyrows
    LeereZeilenAusblenden
    
    
    '~~>'export to PDF if a folder was selected
    If strPathFile <> "" Then
        CurrentWS.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        fileName:=strPathFile, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    Else
        Exit Sub
    End If
    
    LeereZeilenEInblenden
    
    Application.ScreenUpdating = True

      '~~>'confirmation message with file info
      If Err = 0 Then MsgBox "Datei erstellt." & vbCrLf & strPath & vbCrLf & strName, vbInformation
exitHandler:
      Exit Sub
errHandler:
      MsgBox "Datei konnte nicht erstellt werden.", vbInformation
      Resume exitHandler
  
End Sub

Sub LeereZeilenAusblenden()
    Application.ScreenUpdating = False
    For Each c In Workbooks.Application.Range("C22:C72")
        If c.Value = "" Then
            c.EntireRow.Hidden = True
        Else
            c.EntireRow.Hidden = False
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Sub LeereZeilenEInblenden()
    Application.ScreenUpdating = False
    For Each c In Workbooks.Application.Range("C22:C72")
            c.EntireRow.Hidden = False
    Next
    Application.ScreenUpdating = True
End Sub

Function IsFileOpen(fileName As String)

Dim fileNum As Integer
Dim errNum As Integer

'Allow all errors to happen
On Error Resume Next
fileNum = FreeFile()

'Try to open and close the file for input.
'Errors mean the file is already open
Open fileName For Input Lock Read As #fileNum
Close fileNum

'Get the error number
errNum = Err

'Do not allow errors to happen
On Error GoTo 0

'Check the Error Number
Select Case errNum

    'errNum = 0 means no errors, therefore file closed
    Case 0
    IsFileOpen = False
 
    'errNum = 70 means the file is already open
    Case 70
    IsFileOpen = True

    'Something else went wrong
    Case Else
    IsFileOpen = errNum

End Select

End Function


Sub SaveAreaAsXLSX()
  
  Dim NewWB As Workbook
  Dim CurrentWS  As Worksheet
  Dim strName, strPath, strFile, strFileExt, strPathFile As String
  Dim myFile  As Variant
    
  On Error GoTo errHandler
  
  Application.ScreenUpdating = False
  
  '~~> Set the relevant sheet from where you want to copy
  Set CurrentWS = ThisWorkbook.ActiveSheet
  
  strPath = CurrentWS.Range("L2").Text
  If strPath = "" Then strPath = Application.ActiveWorkbook.Path
  strPath = strPath & "\Rechnungen\"
  
  '~~> check if the folder exists, if not create it
  If Dir(strPath, vbDirectory) = "" Then
   MsgBox "Neuer Ordner Erstellt " & vbCrLf & strPath, vbInformation
   MkDir strPath
  End If
  
  strName = CurrentWS.Range("A20").Text & " - " & CurrentWS.Range("D15").Value
  
  strName = Replace(strName, ".", "-")
  strName = Replace(strName, ",", " -")
  
     If strName = " - " Then
          MsgBox "Dateiname Leer" & vbCrLf & "Bitte A20 und D15 ausfüllen", vbCritical
        Exit Sub
    End If
    

    '~~> create default name for saving file
    strFileExt = strName & ".xlsx"
    strPathFile = strPath & strFileExt
    

     
        '~~> check if the file is open
        If IsFileOpen(strPathFile) = True Then
            MsgBox "Die Datei ist geöffnet, bitte schliessen Sie." & vbCrLf & strPath & vbCrLf & strName, vbInformation
            Exit Sub
        End If
         
         '~~> check if the file exists
         If Dir(strPathFile) <> "" Then
        MsgBox "Datei bereits vorhanden " & vbCrLf & strPath & vbCrLf & strName, vbInformation
        
        '~~> user can enter name and select folder for file
        myFile = Application.GetSaveAsFilename(InitialFileName:=strPathFile, FileFilter:="Excel Dateien (*.xlsx), *.xlsx", Title:="Datei speichern unter")
        
        If myFile = 0 Then
            Exit Sub
        Else
            strPathFile = myFile
       End If
    End If

       
    '~~> export to Excel if a folder was selected
    If strPathFile <> "" Then
    
          '~~> Destination/Output Workbook
          Set NewWB = Workbooks.Add
        
          With NewWB
          
            .SaveAs fileName:=strPathFile, FileFormat:=51 'strPath & strName
            
            '~~> Copy the range
            CurrentWS.Range("a1:g100").Copy
          
            NewWB.Sheets(1).Paste 'Copy Image
            NewWB.Sheets(1).Range("a1").PasteSpecial Paste:=xlPasteFormats
            NewWB.Sheets(1).Range("a1").PasteSpecial Paste:=xlPasteColumnWidths
            NewWB.Sheets(1).Range("a1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            NewWB.Sheets(1).Rows(1).RowHeight = 10
            NewWB.Sheets(1).Rows(80).RowHeight = 330
          
             '~~> Hide Emptyrows
              LeereZeilenAusblenden
              
            '~~> Setup The Page Layout, Footer, Printarea
             With NewWB.Sheets(1).PageSetup
                  .LeftFooter = "&13 &F"
                  .RightFooter = "&13  Seite &P von &N"
                   .LeftMargin = Application.InchesToPoints(0.35)
                  .RightMargin = Application.InchesToPoints(0.35)
                  .TopMargin = Application.InchesToPoints(0.75)
                  .BottomMargin = Application.InchesToPoints(0.75)
                  .HeaderMargin = Application.InchesToPoints(0.3)
                  .FooterMargin = Application.InchesToPoints(0.3)
                  .Zoom = False
                  .PaperSize = xlPaperA4
                  .FitToPagesWide = 1
                  .FitToPagesTall = AUTO
              End With
                  
            NewWB.Close Savechanges:=True
            Application.CutCopyMode = False
            Application.ScreenUpdating = True
        
        End With
        
        Else
            Exit Sub
        End If
        


      '~~>'confirmation message with file info
      If Err = 0 Then MsgBox "Datei erstellt." & vbCrLf & strPath & vbCrLf & strName, vbInformation
exitHandler:
      Exit Sub
errHandler:
      MsgBox "Datei konnte nicht erstellt werden.", vbInformation
      Resume exitHandler
  
End Sub

 

 

 

 

 

 

 

 

 

0 Replies