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
Related
I used the code that I found here.
After some changes this is the code I have now:
Option Explicit
Sub ExportAsCSV()
Dim MyFileName As String
Dim Item As String
Dim Path As String
Dim CurrentWB As Workbook, TempWB As Workbook
Path = "F:\Excels\csv export\"
Set CurrentWB = ActiveWorkbook
ActiveWorkbook.Worksheets("Nieuw Artikelnummer").UsedRange.Copy
Item = Range("D2")
Set CurrentWB = ActiveWorkbook
ActiveWorkbook.Worksheets("csv").UsedRange.Copy
Set TempWB = Application.Workbooks.Add(1)
With TempWB.Sheets(1).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
MyFileName = Path & "\" & Item & ".csv"
Application.DisplayAlerts = False
TempWB.SaveAs filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
MsgBox ".csv file has been created: " _
& vbCrLf _
& MyFileName
End Sub
The problem I have is that it uses the UsedRange, but I would like to select the Range that is copied into the new .csv file.
What can I do to select the Range to copy into the new file instead of the UsedRange?
This will open an input box on the article number sheet that allows you to hand select or type in a range:
Sub ExportAsCSV()
Dim MyFileName As String
Dim Item As String
Dim Path As String
Dim CurrentWB As Workbook, TempWB As Workbook
Dim myrangeNA As Range
Dim myRangeCSV As Range
Path = "F:\Excels\csv export\"
Set CurrentWB = ActiveWorkbook
ActiveWorkbook.Worksheets("Nieuw Artikelnummer").Activate
Set myrangeNA = Application.InputBox(prompt:="Select a range to copy", Type:=8)
Item = Range("D2")
Set TempWB = Application.Workbooks.Add(1)
myrangeNA.Copy Destination:=TempWB.Worksheets("Sheet1").Range("A1")
MyFileName = Path & "\" & Item & ".csv"
Application.DisplayAlerts = False
TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
MsgBox ".csv file has been created: " _
& vbCrLf _
& MyFileName
End Sub
If you don't want to select it, change the myrangeNA to whatever range you want, like range("A5:C20") and it should work.
For situations like this, I prefer to isolate the actions to a standalone Sub or Function that I can call with parameters. In this way I can reuse it as needed, either in this project or another one.
So I've separated the actions of copying the selected data range and pasting to a temporary workbook, then saving to a CSV file in it's own Function. The action returns a True/False result as a check for success.
Option Explicit
Sub test()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Dim destCSVfile As String
destCSVfile = "C:\Temp\" & ws.Range("D2")
If ExportAsCSV(Selection, destCSVfile) Then
MsgBox ".csv file has been created: " _
& vbCrLf _
& destCSVfile
Else
MsgBox ".csv file NOT created"
End If
End Sub
Private Function ExportAsCSV(ByRef dataArea As Range, _
ByVal myFileName As String) As Boolean
'--- make sure we have a range to export...
ExportAsCSV = False
If dataArea Is Nothing Then
Exit Function
End If
dataArea.Copy
'--- create a temporary workbook that will be saved as a CSV format
Dim tempWB As Workbook
Set tempWB = Application.Workbooks.Add(1)
With tempWB.Sheets(1).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
'--- suppress alerts to convert the temp book to CSV
Application.DisplayAlerts = False
tempWB.SaveAs filename:=myFileName, FileFormat:=xlCSV, _
CreateBackup:=False, Local:=True
tempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
ExportAsCSV = True
End Function
Your other two questions in the comment above mention pasting transposed values, which you would do by changing the line myrangeNA.Copy Destination:=TempWB.Worksheets("Sheet1").Range("A1") to
myrangeNA.Copy
TempWB.Worksheets("Sheet1").Range("A1").PasteSpecial _
Paste:=xlPasteValues, Transpose:=True
This site is a great reference source for all the various objects and methods and properties in the Office VBA collection: https://learn.microsoft.com/en-us/office/vba/api/overview/excel/object-model
(or https://learn.microsoft.com/de-de/office/vba/api/overview/excel/object-model if you prefer to have about five words translated to German)
I have an Excel file which has a button "Generate PDF" that runs a macro to print a certain sheet (lets call it "QUOTE") into a PDF. This sheet is shown to be well limited in margins and in my computer the created PDF has the perfect structure: everything is well included in 1 page. However, in some other computers, when the PDF is created, everything does not fit into 1 page and a 2nd page is created with a bit of content. Here is the code (including the attempts to fix this problem by limiting the margins):
Sub Excel_Export_Proposal()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsCOTIZACION As Worksheet
Dim Proposalname As String
Dim iVis As XlSheetVisibility
Dim xlName As Excel.Name
Dim FolderPath As String
Dim myRange As String
Set wsQUOTE = ThisWorkbook.Sheets("QUOTE")
FolderPath = ActiveWorkbook.Path & "\"
Proposalname = "Quote for " & CStr(Range("B2").Value)
wsQUOTE.PageSetup.PrintArea = myRange
With wsQUOTE.PageSetup
.FitToPagesTall = 1
.FitToPagesWide = False
.Zoom = False
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.4)
.BottomMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(0.75)
End With
'Proposal
Application.ScreenUpdating = False
wb.Unprotect
With wsQUOTE
iVis = .Visible
.Visible = xlSheetVisible
.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ActiveWorkbook.Path & "\" & Proposalname & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=True, _
OpenAfterPublish:=True
.Visible = iVis
wsQUOTE.Activate
End With
wb.Protect
Application.ScreenUpdating = True
End Sub
Can somebody help me fixing this problem? I would like that the sheet would we printed perfectly regardless of the computer or software in which is generated...
In order to have the procedure Excel_Export_Proposal including the PrintingArea in one page always the following adjustments should be applied:
Set the printing area correctly:
This line sets the printing area: wsQUOTE.PageSetup.PrintArea = myRange
However no value is assigned to the variable myRange before this line, therefore the PrintArea is set to "" which is equivalent to setting it to the entire UsedRange of the wsQUOTE sheet.
To ensure that the entire PrintArea is printed in one page the FitToPagesTall and FitToPagesWide must be set to 1
Replace .FitToPagesWide = False with .FitToPagesWide = 1
And remove .Zoom = False as it has not effect after setting FitToPagesTall and FitToPagesWide to 1
To ensure that the ExportAsFixedFormat method uses the print areas as defined in the target excel file set the IgnorePrintAreas parameter to False.
Replace this line IgnorePrintAreas:=True, _ with this line IgnorePrintAreas:=False, _
Below is the revised procedure:
Sub Excel_Export_Proposal_Revised()
Dim wb As Workbook, wsQuote As Worksheet
Dim myRange As String, Proposalname As String, FolderPath As String
Dim iVis As XlSheetVisibility
Set wb = ThisWorkbook
Set wsQuote = wb.Sheets("QUOTE")
FolderPath = wb.Path & "\"
Proposalname = "Quote for " & wsQuote.Range("B2").Value2
'Update myRange with the address of the range to be printed
myRange = "$B$2:$O$58" 'Change as required
Application.ScreenUpdating = False
With wsQuote.PageSetup
.PrintArea = myRange
.FitToPagesTall = 1
.FitToPagesWide = 1 'Set FitToPagesWide to 1
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.4)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
End With
'Proposal
wb.Unprotect
With wsQuote
iVis = .Visible
.Visible = xlSheetVisible
.Activate
.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=FolderPath & Proposalname & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
.Visible = iVis
End With
wb.Protect
Application.ScreenUpdating = True
End Sub
See following pages for additional information on the resources used:
Worksheet.ExportAsFixedFormat Method (Excel)
PageSetup Object (Excel)
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.
I have a macro written that take a range from one workbook and copies into into a new workbook, which then saves the newly created workbook (and gives it a name) into the same folder path. When this workbook already exists, (overwriting the workbook), the default windows dialogue box pops up asking if you would like to overwrite, with a yes no cancel selection of buttons. When the cancel button is pressed, a new workbook is created. How do I edit this code so that when cancel is pressed, no new workbook is created? I have pasted the macro below:
Sub ExportNewBook()
Application.ScreenUpdating = False
Dim ThisWB As Workbook
Set ThisWB = ActiveWorkbook
Set NewBook = Workbooks.Add
On Error Resume Next
ThisWorkbook.Worksheets("Summary").Range("A1:I100").Copy
NewBook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteValues)
NewBook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteFormats)
NewBook.Worksheets("Sheet1").Range("A:J").Columns.AutoFit
NewBook.SaveAs Filename:=ThisWB.Path & "\" & NewBook.Worksheets("Sheet1").Range("A4").Value & "_Summary"
NewBook.ActiveSheet.Range("A1").Select
Application.ScreenUpdating = True
End Sub
EDIT: WORKING CODE SHOWN BELOW
Sub ExportNewBook()
Application.ScreenUpdating = False
Dim ThisWB As Workbook
Dim fname As String
Set ThisWB = ActiveWorkbook
Set Newbook = Workbooks.Add
ThisWorkbook.Worksheets("Summary").Range("A1:I100").Copy
Newbook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteValues)
Newbook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteFormats)
Newbook.Worksheets("Sheet1").Range("A:J").Columns.AutoFit
fname = ThisWB.Path & "\" & ThisWB.Worksheets("Summary").Range("A4").Value & "_Summary.xls"
If Dir(fname) <> "" Then
If MsgBox("Summary output already exists, are you sure you want to overwrite?", vbOKCancel) = vbCancel Then Newbook.Close False: Application.CutCopyMode = False: Exit Sub
End If
Application.DisplayAlerts = False
Newbook.SaveAs Filename:=fname
Application.DisplayAlerts = True
ThisWB.Activate
ActiveWorkbook.Worksheets("Summary").Range("A1").Select
Newbook.Activate
ActiveWorkbook.ActiveSheet.Range("A1").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Thank you!
On error resume next is seldom a good idea. If the user selects no or cancel, an error is triggered. Better to handle that error to delete the unwanted workbook (although another idea is to test if a workbook with the target name exists before creating it and, if it does, use msgbox to ask the user if they want to overwrite the file and, if so, only then create the workbook, disable alerts, and only then do saveas).
A problem seems to be that you need to have a filename to kill a workbook. In your situation the workbook doesn't yet have a filename. One solution is to create a safe filename whose sole purpose in life is to kill an unwanted workbook, do saveas again with this name, then kill it. Something like this:
Sub Test()
On Error GoTo err_handler
Dim wb As Workbook
Dim fname As String
Dim tempname As String
fname = "C:\Programs\testbook.xlsx"
Set wb = Workbooks.Add
wb.Sheets(1).Range("A1").Value = Now 'for testing purposes
wb.SaveAs fname
Exit Sub
err_handler:
tempname = "C:\Programs\name_i_will_never_use.xlsx"
wb.SaveAs tempname
wb.Close
Kill tempname
End Sub
Here is a possible approach:
Sub ExportNewBook()
Application.ScreenUpdating = False
Dim ThisWB As Workbook, Newbook As Workbook
Dim fname As String
Set ThisWB = ActiveWorkbook
fname = ThisWB.Path & "\" & ThisWB.Sheets("Sheet1").Range("A4").Value & "_Summary"
If Dir(fname) <> "" Then
If MsgBox("Are you sure you want to overwrite?", vbOKCancel) = vbCancel Then Exit Sub
End If
Set Newbook = Workbooks.Add
ThisWB.Worksheets("Summary").Range("A1:I100").Copy
Newbook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteValues)
Newbook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteFormats)
Newbook.Worksheets("Sheet1").Range("A:J").Columns.AutoFit
'This code should be faster since it bypasses the copy-paste buffer
'With Newbook.Sheets(1)
' ThisWB.Sheets("Summary").Range("A1:I100").Copy .Range("A1")
' .Range("A1:I100").Value = .Range("A1:I100").Value
' .Columns.AutoFit
'End With
Application.DisplayAlerts = False
Newbook.SaveAs Filename:=fname
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
this is the full code with
check if file already exist
if exist close the newbook and ask you if the existed file will be opened
close the newbook
in case of error save the newbook with (error) suffix before the extension file
Sub ExportNewBook()
Application.ScreenUpdating = False
Dim ThisWB As Workbook
Dim NewName As String
Set ThisWB = ActiveWorkbook
Set NewBook = Workbooks.Add
On Error GoTo err_handler
ThisWB.Worksheets("Summary").Range("A1:I100").Copy
NewBook.Worksheets("Foglio1").Range("A1").PasteSpecial (xlPasteValues)
NewBook.Worksheets("Foglio1").Range("A1").PasteSpecial (xlPasteFormats)
NewBook.Worksheets("Foglio1").Range("A:J").Columns.AutoFit
NewName = ThisWB.Path & "\" & NewBook.Worksheets("Foglio1").Range("A4").Value & "_Summary.xls"
If Dir(NewName) "" Then
If MsgBox("A file named '" & NewName & " already exists." & vbCr & vbCr & _
MeaName & " will now open??", vbYesNo) = vbYes Then
Workbooks.Open NewName
End If
NewBook.Close False
Exit Sub
End If
NewBook.SaveAs Filename:=NewName
NewBook.ActiveSheet.Range("A1").Select
NewBook.Close
Application.ScreenUpdating = True
err_handler:
NewName = ThisWB.Path & "\" & NewBook.Worksheets("Foglio1").Range("A4").Value & "_Summary(error).xls"
NewBook.SaveAs Filename:=NewName
NewBook.ActiveSheet.Range("A1").Select
NewBook.Close
Application.ScreenUpdating = True
End Sub
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