I am new to excel macros, I am working on creating a macro which needs to format the cells and also to generate the bar code for column A. Created a function Code128() to convert the string in to bar code as given in the blog and it works fine.
I am using them in the macros I am creating like below
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintGridlines = True
.Orientation = xlLandscape
.PaperSize = xlPaperA4
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
Columns("A").ColumnWidth = 10
For Each Target In Range("A1", Range("A" & Rows.Count).End(xlUp))
If Target.Value <> vbNullString Then
Target.Value = PERSONAL.XLSB!Code128(Target.Value)
Target.Resize(, 12).WrapText = True
Target.Font = "Code 128"
End If
Next
Next
But when I run the macro on the excel I am getting the run time error like
You should be able to use Application.Run to evaluate a function that exists in another workbook. The format of that is:
Target.Value = Application.Run("PERSONAL.XLSB!Module2.Code128", Target.Value)
Or more generally:
= Application.Run(workbookname$ & "!" & modulename & "." & functionname, args())
Barring that, you could Add a reference to Personal.xlb in your Book1.
Related
With wb
Set Sh2 = .Sheets("sheet2)
With Sh2.PageSetup
.PrintArea = "$B$2:$S$80"
.PaperSize = xlPaperLegal
End With
Set Sh3 = .Sheets("sheet3")
With Sh3.PageSetup
.PrintArea = "$B$2:$M$104"
.PaperSize = xlPaperLegal
.Orientation = xlPortrait
End With
Set execsum1 = .Sheets("sheet4")
With execsum1.PageSetup
.PrintArea = "$B$7:$N$63"
.PaperSize = xlPaperLegal
.Orientation = xlLandscape
.PrintTitleRows = "$B$2:$N$6"
End With
Set execsum2 = .Sheets("sheet5")
With execsum2.PageSetup
.PrintArea = "$B$64:$N$106"
.PaperSize = xlPaperLegal
.Orientation = xlLandscape
.PrintTitleRows = "$B$2:$N$6"
End With
'ActiveSheet.PrintPreview
Set noi1 = .Sheets("sheet6")
With noi1.PageSetup
.PrintArea = "$B$10:$N$44"
.PaperSize = xlPaperLegal
.Orientation = xlLandscape
.PrintTitleRows = "$B$2:$N$8"
.FitToPagesTall = 1
End With
Set noi2 = .Sheets("sheet7")
With noi2.PageSetup
.PrintArea = "$B$46:$N$192"
.PaperSize = xlPaperLegal
.Orientation = xlLandscape
.PrintTitleRows = "$B$2:$N$8"
'.FitToPagesWide = 1
.FitToPagesTall = 1
End With
End With
Dim sheet As Variant
For Each sheet In Array(execsum1, execsum2, Sh2, Sh3, noi1, noi2)
sheet.PrintOut Copies:=1
Next
'Save and Close Workbook
'wb.Close SaveChanges:=False
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Hello all, I'm new to VBA and I'm trying to print 6 worksheets/pages per workbooks found in a folder. Execsum1 and execsum2 are from the same worksheet with different print areas; same story with noi1 and noi2. When I run the code, it prints out the second designated page twice (execsum2 and noi2). Why isn't execsum1/noi1 printing out and if possible, how can I make the code more efficient? Thanks.
It prints the same sheet twice because you aren't printing the worksheet between changing the PageSetup from your first version to your second version. You collect worksheet references here...
Set execsum1 = .Sheets("Exec Summary")
'...
Set execsum2 = .Sheets("Exec Summary")
...that are identical to each other. A worksheet only has 1 PageSetup, so when you do this...
For Each sheet In Array(execsum1, execsum2, Sh2, Sh3, noi1, noi2)
sheet.PrintOut Copies:=1
Next
...you get the last thing it was set to.
Just skip the loop entirely and print each individually. There is absolutely no benefit to looping over them.
With execsum1.PageSetup
.PrintArea = "$B$7:$N$63"
.PaperSize = xlPaperLegal
.Orientation = xlLandscape
.PrintTitleRows = "$B$2:$N$6"
End With
execsum1.PrintOut Copies:=1 '<--- After each With block.
If you want to simplify the code, just extract out the common .PageSetup into a function, and pass everything else as a parameter (note that this is just an example - I didn't include everything you're using). I.e.:
Private Sub PrintCustomRange(sheet As Worksheet, area As String, title As String, _
orient As XlPageOrientation, paper As XlPaperSize)
With sheet.PageSetup
.PrintArea = area
.PaperSize = paper
.Orientation = orient
If Len(title) > 0 Then .PrintTitleRows = title
End With
.PrintOut Copies:=1
End Sub
Then call it like this:
PrintCustomRange Sheets("Proforma NOI"), "$B$46:$N$192", "$B$2:$N$8", xlLandscape, xlPaperLegal
Problem: I am having a problem with data validations not copying to the copied worksheet when a worksheet is copied using a macro. Is there any way to do this using my current code?
Yes, I am also aware that there is a similar question (Here: Data validation lost when I copy a worksheet to another workbook) but it isn't quite the same issue and does not yet at this time have an answer. Any help to get these data validations to copy along with the data would be much appreciated and will save hours of needless repetitive work.
Edit: This code is in the "ThisWorkbook" section of my workbook.
My code is as follows:
Dim wb As Workbook
Dim wsTemp As Worksheet
Dim sName As String
Dim bValidName As Boolean
Dim i As Long
bValidName = False
Do While bValidName = False
sName = InputBox("Please name this new worksheet:", "New Sheet Name", Sh.Name)
If Len(sName) > 0 Then
For i = 1 To 7
sName = Replace(sName, Mid(":\/?*[]", i, 1), " ")
Next i
sName = Trim(Left(WorksheetFunction.Trim(sName), 31))
If Not Evaluate("ISREF('" & sName & "'!A1)") Then bValidName = True
End If
Loop
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Set wb = ThisWorkbook
Set wsTemp = wb.Sheets("TEMPLATE")
wsTemp.Visible = xlSheetVisible
wsTemp.Copy After:=wb.Sheets(wb.Sheets.Count)
ActiveSheet.Name = sName
Sh.Delete
wsTemp.Visible = xlSheetHidden 'Or xlSheetVeryHidden
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
' Call Sort_Active_book
' Call Rebuild_TOC
You should be able to copy a worksheet and retain DV. This example:
Activates Sheet1
creates a simple DV on Sheeet1
copies Sheet1 to the end of the workbook
Sub Macro2()
Sheets("Sheet1").Select
Range("D1").Select
ActiveCell.FormulaR1C1 = "alpha"
Range("D2").Select
ActiveCell.FormulaR1C1 = "beta"
Range("D3").Select
ActiveCell.FormulaR1C1 = "gamma"
Range("B1").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$D$1:$D$3"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Sheets("Sheet1").Select
Sheets("Sheet1").Copy After:=Sheets(3)
End Sub
This is recorded code run on a new, empty workbook on a Win 7/Excel 2007 system.
Can you replicate my result ??
If my code works on your system, begin by trying to mimic your VBA code manually with the recorder turned. Then take your recorded code and modify it to include non-recordable parts, (like the InputBox statements).
I am trying to run my code with GetOpenFileName function in it. When I am not selecting a file, I am unsure of what is the value that is returned in variable fName. The way my code is right now, If I "Do Not" select a file, it returns the message box as written(which is what I want) but as I click ok, it takes me to a random spot in my workbook(something I also need help on), but main issue is, when I "Do" select a file to run, it gives me back a "Type mismatch error" even when my variable is defined as Variant. Without this addition to my code, the code runs great but I want to add this functionality. Thanks in advance for the help!
Dim fName As Variant
fName = Application.GetOpenFilename( _
FileFilter:="*.xlsx(*.xlsx),*.xls,*.xlsm (*.xlsm),*.xlsm", _
Title:="Select a file or files", _
MultiSelect:=True)
If fName = "False" Then
MsgBox "Select a file to proceed"
Else
Sheets("Main").Select
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
If bIsBookOpen(FnameInLoop) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(Fname(N))
On Error GoTo 0
' Sub CopyData()
'
' CopyData Macro
'
'
Sheets("Sheet1").Select
Columns("A:O").Select
Selection.Copy
Windows("SupplierDeliveryPerfWall_MasterSheet").Activate
' ActiveSheet.Select
' ActiveSheet.Name = "Data"
Sheets("Data").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
If Not mybook Is Nothing Then
mybook.Close SaveChanges:=True
End If
Else
MsgBox "We skipped this file : " & Fname(N) & " because it is already open."
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
' Change drive/directory back to SaveDriveDir.
ChDrive SaveDriveDir
ChDir SaveDriveDir
'Insert data validation column
Windows("SupplierDeliveryPerfWall_MasterSheet").Activate
Sheets("Data").Select
Range("A2:O2000").Select
' Unmerge data that is copied from Oracle
Range("A2:O2000").UnMerge
' Sub sbInsertingColumns()
'Inserting a Column at Column E for reason codes
Range("E1").EntireColumn.Insert
Range("E1").Select
ActiveCell.FormulaR1C1 = "Reason Code"
ActiveCell.Offset(1, 0).Range("A1").Select
'Inserting a Column at Column F for Comments
Range("F1").EntireColumn.Insert
Range("F1").Select
ActiveCell.FormulaR1C1 = "Comments"
Range("F1").Select
Application.CutCopyMode = False
' Inserting data validation
Sheets("Main").Select
Range("AF2:AF2000").Select
Selection.Copy
Sheets("Data").Select
Range("E2").Select
ActiveSheet.Paste
' Insert Comment in data validation
Range("E2").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="='Reason Codes'!$A$2:$A$500"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = "Select Reason Code"
.ErrorTitle = "Select from list"
.InputMessage = ""
.ErrorMessage = "If exception, enter in COMMENTS column"
.ShowInput = True
.ShowError = True
End With
Range("E2").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="='Reason Codes'!$A$2:$A$500"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Select from list"
.InputMessage = "Select Reason Code"
.ErrorMessage = "If exception, enter in COMMENTS column"
.ShowInput = True
.ShowError = True
End With
Next
End If
End Sub
main issue is, when I "Do" select a file to run, it gives me back a "Type mismatch error" even when my variable is defined as Variant.
This is because you have MultiSelect:=True. This is problematic because sometimes the result will be an array and other times (if the user cancels) it will be a boolean. So first you need to test whether the return value is an array or not. If it's an array, the iterate the selected files. If not, then do the MsgBox prompt.
Sub foo()
Dim FileNames
Dim file
FileNames = Application.GetOpenFilename( _
FileFilter:="*.xlsx(*.xlsx),*.xls,*.xlsm (*.xlsm),*.xlsm", _
Title:="Select a file or files", _
MultiSelect:=True)
If IsArray(FileNames) Then
For Each file In FileNames
'Do something to each file
Next
Else
'This really can't be anything other than FALSE:
If Not FileNames Then
MsgBox "No files selected"
Exit Sub
End If
End If
End Sub
If you don't need to allow multi-select, then just use the Dir() function.
fName = Application.GetOpenFilename( _
FileFilter:="*.xlsx(*.xlsx),*.xls,*.xlsm (*.xlsm),*.xlsm", _
Title:="Select a file", _
MultiSelect:=False)
If Dir(CStr(fName)) = vbNullString Then
MsgBox "Select a file to proceed"
Exit Sub
Else
'Do something to the file
End If
I have code which formats a worksheet to the desired setup and layout (one page wide and tall in landscape). When I run the code (part of a long macro) it formats the pagesetup correctly.
If I manually export and save it as a pdf, then it uses the correct page setup, producing a one page PDF that is in landscape. However, the same export done by VBA produces a PDF that is severalpages long and in portrait.
i can't figure out why it's doing this. i've tried various solutions such as selecting the worksheet before exporting it, but all to no avail.
Any help is appreciated.
Code looks like this:
Sub SaveAsPDF()
Sheets(ReportWsName).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
[SaveFolderPath] & "\" & ReportWsName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
End Sub
UPDATE:
Code used to format the pagesetup (since it's rather long I am only adding the relevant section of that sub)
Private Sub CreateNewReport(ProvisionCode As String, TimeFrom As Date, TimeTo As Date)
... other code here...
'Format report to create the desired layout
With Worksheets(ReportWsName)
'Delete unnecessary data and format the rest
.Range("A:B,D:D,F:G,J:M,O:O,Q:S").Delete Shift:=xlToLeft
.Range("A:F").EntireColumn.AutoFit
.Range("C:C, E:F").ColumnWidth = 30
With .Range("G:G")
.ColumnWidth = 100
.WrapText = True
End With
'Insert standard formating header form Reporting template
.Rows("1:2").Insert
wsReportTemplate.Range("1:3").Copy .Range("A1")
.Range("A2") = "Notes Report for " & ProvisionCode & " (" & TimeFrom & " - " & TimeTo & ")"
'Insert standard formating footer form Reporting template
wsReportTemplate.Range("A6:G7").Copy .Range("A" & .UsedRange.Rows.Count + 2)
'Ensure all data is hard coded
.UsedRange.Value = .UsedRange.Value
'Format Print Area to one Page
With ActiveSheet.PageSetup
.PrintArea = Worksheets(ReportWsName).UsedRange
.Orientation = xlLandscape
.FitToPagesWide = 1
End With
End With
End Sub
I have found what seems to be the solution:
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.Orientation = xlLandscape
.Zoom = False
'.PrintArea = Worksheets(ReportWsName).UsedRange
.FitToPagesWide = 1
'.FitToPagesTall = 1
End With
Application.PrintCommunication = True
I needed to add the Application.PrintCommunication part to the equation. For whatever reason Excel would overwrite the settings I was putting if I ran the code without it.
I think the problem is that you need to add the .Zoom = False to your page setup code:
'Format Print Area to one Page
With ActiveSheet.PageSetup
.PrintArea = Worksheets(ReportWsName).UsedRange
.Orientation = xlLandscape
.FitToPagesWide = 1
.Zoom = False 'I have added this line
End With
From what I have tried this should solve it for you.
Let me know how it goes!
EDIT: Maybe you need:
'Format Print Area to one Page
With ActiveSheet.PageSetup
.PrintArea = Worksheets(ReportWsName).UsedRange
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 1
.Zoom = False 'I have added this line
End With
EDIT2: What if you changed:
.PrintArea = Worksheets(ReportWsName).UsedRange
To
.PrintArea = Worksheets(ReportWsName).UsedRange.Address
Yes!!!, I have had the same problem: I was not able to export a sheet with the page Setup settings already applied on it.
Before trying the Application.PrintCommunication I tested Wait and Sleep commands without success. Finally I skipped this issue by using CopyPicture method, adding a chart page and then exporting it to pdf, but resolution in my pdf it was not fine and I was not able to play with margins.
So just add Application.PrintCommunication=false before your code , on pagesetup settings like CaptainABC says and most important: close with Application.PrintCommunication=true after the code.
Thank you for this useful post.
I wonder if anybody can help me. I have a macro which selects sheets that are named as employees and puts them into the correct workbook dependant on where they work.
I have made the macro so that it selects all sheets for the depot then copies them into a new workbook.
My problem is when it can't find one of the sheets it skips all of them for that location workbook. and moves to the next location. Is there a way round this so if the macro can't find one of the sheets it moves the rest of them anyway.
Sub BIR()
On Error GoTo Getout
Sheets(Array("Martyn Arthur Lewis", "Norman Stewart Gray")).Move
Sheets.Select
For Each ws In Worksheets
ws.Activate
With ActiveSheet.PageSetup
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 90
.printerrors = xlPrintErrorsBlank
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = False
End With
Next
ChDir "\\afi-uplift\documents\company\Support Services\Support Services Level 1\Reports\Transport Reports\Vehicle KPI"
ActiveWorkbook.SaveAs Filename:="\\afi-uplift\documents\company\Support Services\Support Services Level 2\Support Services\Transport\Drivers\Driver Performance\BIR Driver KPI " & Format(Date, "yyyy.mm.dd") & ".xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Windows("Driver Report.xlsm").Activate
Getout:
End Sub
I don't understand why people always need to use .select and .activate
First it slows the program, and second, usualy, you don't even need to select/activate.
Doesn't your code work if you write it like this :
option explicit 'forces user to dim variables, , alot easier to find errors
err.clear
on error goto 0 'how can you debug errors with a on error goto (or on error resume next) ?
dim ws as worksheet
For Each ws In Sheets(Array("Martyn Arthur Lewis", "Norman Stewart Gray"))
With ws.PageSetup
'your code
end with
next ws