Jan 19 2022 12:28 PM - edited Jan 24 2022 06:39 AM
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