Here are my code to export all sheets of excel to PDF:
Sub printing()
Dim i As Integer, wkb As String, head As String, nm As String
Dim ws As Worksheet
Application.ScreenUpdating = False
'get folder path
wkb = InputBox("Enter folder path:", , ActiveWorkbook.Path)
If Right(wkb, 1) <> Application.PathSeparator Then wkb = wkb & Application.PathSeparator
'head of file name
head = InputBox("Enter head of file name", , "Test")
Application.DisplayAlerts = False
For Each ws In ActiveWorkbook.Worksheets
'ActiveWorkbook.Sheets.Count
If ws.Visible = True Then
ws.Select
nm = ws.Range("A1")
If nm <> "" Then
'save
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=wkb & head & nm & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End If
Application.DisplayAlerts = False
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
I run this macro on my Mac and my friend's Mac, But my Mac is pass,and my friend's mac not pass and occured an errors:
Run time error '1004':
Method 'ExportAsFixedFormat' of object '_worksheet' failed
Can you tell me a solution to fix it?
Thanks.
Related
I have the following VBA code saving workbook1 sheets to a folder where workbook1 file is saved. Example: workbook1 has 31 sheets. The code saves each sheet to a new workbook with the same name as the sheet. (Sheet1, Sheet2, etc).
Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName & ".xls"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub
I need to modify the code to save the file with the ID and date. The ID is in cell A1. "XXX Clinic Pro Fees Report for Doe, John (JDOE)". In this example I need the new workbook to save as JDOE_2017-10-20.
Is there a way to gave the ID and place the date after it?
Try the below code
Sub SaveShtsAsBook()
Dim ldate As String
Dim SheetName1 As String
ldate = Format(Now(), "yyyy-mm-dd")
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
SheetName1 = Range(A1).Value2 & ldate
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
tempstr = Cells(1, 1).Value2
openingParen = InStr(tempstr, "(")
closingParen = InStr(tempstr, ")")
SheetName1 = Mid(tempstr, openingParen + 1, closingParen - openingParen - 1) & "_" & ldate
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName1 & ".xls"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub
You can extract the name code from within the brackets and append the date with a couple lines of code.
SheetName = Split(Split(.Cells(1, 1).Value2, "(")(1), ")")(0)
SheetName = sn & Format(Date, "_yyyy-mm-dd")
Along with a couple other modifications as,
Option Explicit
Sub SaveShtsAsBook()
Dim ws As Worksheet, sn As String, mfp As String, n As Long
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
On Error Resume Next '<< a folder exists
mfp = ActiveWorkbook.Path & "\" & Split(ThisWorkbook.Name, Chr(46))(0)
MkDir mfp '<< create a folder
On Error GoTo 0 '<< resume default error handling
With ActiveWorkbook
For n = 1 To .Worksheets.Count
With .Worksheets(n)
sn = Split(Split(.Cells(1, 1).Value2, "(")(1), ")")(0)
sn = sn & Format(Date, "_yyyy-mm-dd")
.Copy
With ActiveWorkbook
'save book in this folder
.SaveAs Filename:=mfp & "\" & sn, FileFormat:=xlExcel8
.Close SaveChanges:=False
End With
End With
Next
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
I was using this code to save as PDF a hidden worksheet and it was working perfectly:
Sub Cite()
Dim wb As Excel.Workbook
Dim Proposalname As String
Dim iVis As XlSheetVisibility
Dim xlName As Excel.Name
Dim FolderPath As String
Set wb = ActiveWorkbook
FolderPath = ActiveWorkbook.Path & "\"
Proposalname = "Cite for " & CStr(Range("B2").Value)
'Proposal
Application.ScreenUpdating = False
With Worksheets(2)
iVis = .Visible
.Visible = xlSheetVisible
.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ActiveWorkbook.Path & "\" & Proposalname & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=True, _
OpenAfterPublish:=True
.Visible = iVis
Worksheets(2).Activate
End With
Application.ScreenUpdating = True
End Sub
However, now I protected this hidden sheet with a password so people can't unhide it. After doing this, I am not able to generate the PDF like it was working before. I tried to use the command "Unprotect password" and also did not work, it keeps saying that something is wrong with the line ".Visible = xlSheetVisible". Can somebody help me solving this problem please?
You must unprotect the workbook as well as the worksheet in order to change the visible property of a worksheet
EDIT:
wb.unprotect "Your password here"
With Worksheets(2)
iVis = .Visible
.Visible = xlSheetVisible
more code here
End With
wb.protect "Your password here"
Application.ScreenUpdating = True
I have a requirement to open an existing file from a different location and save each worksheet into different csv files in the name of the worksheet name (tab name).
Sub SplitFile()
Dim vPath As String
vPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=vPath & "\" & xWs.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This works for the currently active workbook but I would like to process another workbook in a particular path.
I tried to assign a variable which holds the file path but it is throwing an error.
You need to create a workbook variable and assign a workbook object to it:
Sub SplitFile()
Dim vPath As String
Dim wb As Workbook
Dim wbPath As Variant
wbPath = Application.GetOpenFileName("Excel Files (*.xls*), *.xls*")
If wbPath = False Then Exit Sub
Set wb = Workbooks.Open(wbPath)
vPath = wb.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In wb.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=vPath & "\" & xWs.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
As you can see, once you've assigned your workbook you just refer to that in your code wherever needed.
I have a workbook (in Excel 2003 format) with data flowing continuously in three sheets. I want to create a macro in a new workbook (Excel 2010) in which all those data in all the three sheets in the previous workbook to get pasted in a single sheet of my new workbook, one after another. I would prefer the macro to open a dialog box to browse the file where the data is actually present. Can anyone help me please?
While searching I found something like given below. But that is not the one I want exactly.
Sub Open_Workbook()
Dim myFile As String
myFile = Application.GetOpenFilename _
(Title:="Please choose a file to open", _
FileFilter:="Excel Files .xls (.xls),")
If myFile = False Then
MsgBox "No file selected.", vbExclamation, "Sorry!"
Exit Sub
Else
Workbooks.Open Filename:=myFile
End If
End Sub
I suppose this code will help you
Sub wb_sheets_combine_into_one()
Dim sFileName$, UserName$, oWbname$, oWbname2$, sDSheet$ 'String type
Dim nCountDestination&, nCount&, nCountCol& 'Long type
Dim oSheet As Excel.Worksheet
Dim oRange As Range
Dim oFldialog As FileDialog
Set oFldialog = Application.FileDialog(msoFileDialogFilePicker)
With oFldialog
If .Show = -1 Then
.Title = "Select File"
.AllowMultiSelect = False
sFileName = .SelectedItems(1)
Else
Exit Sub
End If
End With
'open source workbook
Workbooks.Open sFileName: oWbname = ActiveWorkbook.Name
UserName = Environ("username")
Workbooks.Add: ActiveWorkbook.SaveAs Filename:= _
"C:\Users\" & UserName & _
"\Desktop\Consolidated.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
oWbname2 = ActiveWorkbook.Name
sDSheet = ActiveSheet.Name
nCountDestination = 1
Workbooks(oWbname).Activate
For Each oSheet In Workbooks(oWbname).Worksheets
oSheet.Activate
sDSheet = ActiveSheet.Name
ActiveSheet.UsedRange.Copy
For Each oRange In ActiveSheet.UsedRange
nCountCol = oRange.Column
Next
Workbooks(oWbname2).Activate
Cells(nCountDestination, 1).PasteSpecial xlPasteAll
nCount = nCountDestination
For Each oRange In ActiveSheet.UsedRange
nCountDestination = oRange.Row + 1
Next
Range(Cells(nCount, nCountCol + 1), _
Cells(nCountDestination - 1, nCountCol + 1)).Value = oSheet.Name
Workbooks(oWbname).Activate
With ActiveWorkbook.Sheets(sDSheet).Tab
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0
End With
Next
Workbooks(oWbname2).Save: Workbooks(oWbname).Close False
MsgBox "File with consolidated data from workbook " & Chr(10) & _
"[ " & oWbname & " ] saved on your desktop!"
End Sub
I have a one page excel file that changes based on a drop down selection. I need to be able to export each data set into one PDF. So, I am looking for a macro that would loop through each selection in the drop down menu and have each of those data sets save into a multi page PDF file.
My thought would be to create the loop and have each version saved as a temporary worksheet. Then I could use
ThisWorkbook.Sheets(Array("Sheet1", "Sheet2")).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\tempo.pdf", Quality:= xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
to save all the sheets as one PDF but then I would need to delete all the temp files.
Thanks,
Chris
I suggest exporting them all individually to PDF into a temp directory, stitching them together using Adobe's COM automation library (assuming you have Pro), then deleting the temp folder.
Public Sub JoinPDF_Folder(ByVal strFolderPath As String, ByVal strOutputFileName As String)
On Error GoTo ErrHandler:
Dim AcroExchPDDoc As Object, _
AcroExchInsertPDDoc As Object
Dim strFileName As String
Dim iNumberOfPagesToInsert As Integer, _
iLastPage As Integer
Set AcroExchPDDoc = CreateObject("AcroExch.PDDoc")
Dim strFirstPDF As String
' Get the first pdf file in the directory
strFileName = Dir(strFolderPath + "*.pdf", vbNormal)
strFirstPDF = strFileName
' Open the first file in the directory
If Not (AcroExchPDDoc.Open(strFolderPath & strFileName)) Then
Err.Raise 55555, "JoinPDF_Folder", "Could not open PDF for joining"
End If
' Get the name of the next file in the directory [if any]
If strFileName <> "" Then
strFileName = Dir
' Start the loop.
Do While strFileName <> ""
' Get the total pages less one for the last page num [zero based]
iLastPage = AcroExchPDDoc.GetNumPages - 1
Set AcroExchInsertPDDoc = CreateObject("AcroExch.PDDoc")
' Open the file to insert
If Not (AcroExchInsertPDDoc.Open(strFolderPath & strFileName)) Then
Err.Raise 55555, "JoinPDF_Folder", "Could not open PDF for joining"
End If
' Get the number of pages to insert
iNumberOfPagesToInsert = AcroExchInsertPDDoc.GetNumPages
' Insert the pages
AcroExchPDDoc.InsertPages iLastPage, AcroExchInsertPDDoc, 0, iNumberOfPagesToInsert, True
' Close the document
AcroExchInsertPDDoc.Close
' Delete the document
Kill strFolderPath & strFileName
' Get the name of the next file in the directory
strFileName = Dir
Loop
' Save the entire document as the strOutputFileName using SaveFull [0x0001 = &H1]
If Not (AcroExchPDDoc.Save(PDSaveFull, strOutputFileName)) Then
Err.Raise 55556, "JoinPDF_Folder", "Could not save joined PDF"
End If
End If
' Close the PDDoc
AcroExchPDDoc.Close
Kill strFolderPath & strFirstPDF
CallStack.Pop
Exit Sub
ErrHandler:
GlobalErrHandler
End Sub
Here was my solution:
Sub LoopThroughDD()
'Created by Chrismas007
Dim DDLCount As Long
Dim TotalDDL As Long
Dim CurrentStr As String
TotalDDL = Sheets("Report").DropDowns("Drop Down 10").ListCount
'Loops through DropDown stores
For DDLCount = 1 To TotalDDL
Sheets("Report").DropDowns("Drop Down 10").Value = DDLCount
CurrentStr = "Report" & DDLCount
'Creates a copy of each store and pastes them in a new worksheet
Sheets.Add(After:=Sheets(Worksheets.Count)).Name = "Report" & DDLCount
Sheets("Report").Columns("D:V").Copy
Sheets(CurrentStr).Columns("A:S").Insert Shift:=xlToRight
Sheets(CurrentStr).Range("A1:S98").Select
Selection.Copy
Sheets(CurrentStr).Range("A1:S98").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Sheets(CurrentStr).PageSetup.PrintArea = "$A$1:$S$98"
'Sets worksheet to one page
With Sheets(CurrentStr).PageSetup
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.FitToPagesWide = 1
.FitToPagesTall = 1
.Zoom = False
.CenterHorizontally = True
.CenterVertically = True
End With
Next DDLCount
'Because only visable worksheets will be captured on PDF dump, need to hide temporarily
Sheets("Report").Visible = False
Dim TheOS As String
Dim dd As DropDown
'Going to name the file as the rep name so grabbing that info here
Set dd = Sheets("Report").DropDowns("Drop Down 2")
TheOS = Application.OperatingSystem
'Select all visible worksheets and export to PDF
Dim ws As Worksheet
For Each ws In Sheets
If ws.Visible Then ws.Select (False)
Next
If InStr(1, TheOS, "Windows") > 0 Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & dd.List(dd.ListIndex), Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
Else
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & ":" & dd.List(dd.ListIndex), Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
End If
'Unhide our original worksheet
Sheets("Report").Visible = True
TotalDDL = Sheets("Report").DropDowns("Drop Down 10").ListCount
'Delete all temp worksheets
For DDLCount = 1 To TotalDDL
CurrentStr = "Report" & DDLCount
Application.DisplayAlerts = False
Sheets(CurrentStr).Delete
Application.DisplayAlerts = True
Next DDLCount
DDLCount = Empty
End Sub