We have this problem on many workbooks where we select a few sheets with VBA and print them using the following line and Excel will actually print multiple groups of pages instead of 1 group of multiple pages.
ActiveWindow.SelectedSheets.PrintOut
Here is an example of a Sub that has this behaviour:
Private Sub imprimer(iColTypeRapport As Integer)
Dim cell As range, rangeImpr As range, colonne As range
Dim debute As Boolean ' True seulement si on a déjà sélectionné une feuille
On Error GoTo erreur
application.ScreenUpdating = False
debute = False
Set rangeImpr = ActiveSheet.range("impression")
Set colonne = rangeImpr.Offset(0, iColTypeRapport).EntireColumn
For Each cell In rangeImpr
If LCase(Intersect(cell.EntireRow, colonne)) = "o" Then
If Not debute Then
Worksheets(cell.Value).Select
debute = True
Else
Worksheets(cell.Value).Select False
End If
End If
Next cell
ActiveWindow.SelectedSheets.PrintOut
Worksheets("TableauDeBord").Select
application.ScreenUpdating = True
Exit Sub
erreur:
Call GestionErreur(Err.Number, Err.Description, "modRequete", "ImportData")
End Sub
This is made even more obvious if we use Print2PDF or AdobePDF print as it will prompt multiple times (in this case, 3 times) for file names.
If I put a breakpoint before PrintOut the sheets are selected appropriately and I see nothing unusual / unexpected.
Any idea ?
I've seen this. It can have to do with things like different print resolutions. If you search on "print workbook produces multiple pdfs" you'll find some answers. With the PDF problem specifically, it can be resolved (in XL 2010 and, I'm guessing, 2007) by doing a "Save As" to PDF instead.
Related
Goal: Find headings in a document by their font and font size and put them into a spreadsheet.
All headings in my doc are formatted as Ariel, size 16. I want to do a find of the Word doc, select the matching range of text to the end of the line, then assign it to a variable so I can put it in a spreadsheet. I can do an advanced find and search for the font/size successfully, but can't get it to select the range of text or assign it to a variable.
Tried modifying the below from http://www.vbaexpress.com/forum/showthread.php?55726-find-replace-fonts-macro but couldn't figure out how to select and assign the found text to a variable. If I can get it assigned to the variable then I can take care of the rest to get it into a spreadsheet.
'A basic Word macro coded by Greg Maxey
Sub FindFont
Dim strHeading as string
Dim oChr As Range
For Each oChr In ActiveDocument.Range.Characters
If oChr.Font.Name = "Ariel" And oChr.Font.Size = "16" Then
strHeading = .selected
Next
lbl_Exit:
Exit Sub
End Sub
To get the current code working, you just need to amend strHeading = .selected to something like strHeading = strHeading & oChr & vbNewLine. You'll also need to add an End If statement after that line and probably amend "Ariel" to "Arial".
I think a better way to do this would be to use Word's Find method. Depending on how you are going to be inserting the data into the spreadsheet, you may also prefer to put each header that you find in a collection instead of a string, although you could easily delimit the string and then split it before transferring the data into the spreadsheet.
Just to give you some more ideas, I've put some sample code below.
Sub Demo()
Dim Find As Find
Dim Result As Collection
Set Find = ActiveDocument.Range.Find
With Find
.Font.Name = "Arial"
.Font.Size = 16
End With
Set Result = Execute(Find)
If Result.Count = 0 Then
MsgBox "No match found"
Exit Sub
Else
TransferToExcel Result
End If
End Sub
Function Execute(Find As Find) As Collection
Set Execute = New Collection
Do While Find.Execute
Execute.Add Find.Parent.Text
Loop
End Function
Sub TransferToExcel(Data As Collection)
Dim i As Long
With CreateObject("Excel.Application")
With .Workbooks.Add
With .Sheets(1)
For i = 1 To Data.Count
.Cells(i, 1) = Data(i)
Next
End With
End With
.Visible = True
End With
End Sub
This loop runs typically 4 to 8 times. It updates 30+ textboxes and prints. Has been working great. But we updated from office 2010 to 2016 (and to Office 365), so now it runs but all the textboxes on the printed pages have the same value from iteration 1. Happens on all printers including PDFcreator. But afterwards the sheet is in the state I expect for the last iteration. It's like the code outruns the printer. But adding a delay of even 10 sec does not help. Oddly, as I try different things I see on the first iter that the textboxes update (from the previous runs last iter). Seems like it should update every iter.
Sub printParamSheets()
On Error GoTo errHandler
Dim Bin1_Matl, Bin1_Parts 'Declaring types won't help or speed up
Dim iCond, conditions
Application.EnableEvents = True 'Is not helping with issue
For iCond = 1 To conditions
With Sheet2
'Assign from sheet2 to variables
Bin1_Matl = .Range("A64").Offset(0, iCond * 2).Value2
Bin1_Parts = .Range("B64").Offset(0, iCond * 2).Value2
'about 30 more of these
End With
With Sheet8 'Assign Sheet8 named ranges from variables above.
'Could skip intermed vars but nice for debugging.
'ALL LINKED TO ACTIVEX TEXT BOXES on Sheet8, atop an image.
.Range("Bin1Matl").Value2 = Bin1_Matl
.Range("Bin1Parts").Value2 = Bin1_Parts
'about 30 more of them
.Calculate 'Is not helping with issue
Dim ctrl As OLEObject 'Is not helping with issue
For Each ctrl In .OLEObjects
If TypeName(ctrl.Object) = "TextBox" Then
'ctrl.Update 'error, but was not in 2010 anyway
End If
Next ctrl
Application.Wait (Now + TimeValue("00:00:05")) 'Is not helping
Application.ScreenUpdating = True 'Never toggled off , no help
DoEvents 'Is not helping with issue
.PrintOut from:=1, To:=1, Copies:=1, Collate:=True
End With
Next iCond
Exit Sub
errHandler:
Application.EnableEvents = True 'Don't need but cannot hurt
Resume Next
End Sub
I will try skipping the extra intermediate assignments, going straight from sheet2 to the textboxes. But I'd like to know the cause because I have other code 'in the wild' that doesn't necessarily use any activex objects that may be affected. Hoping the symptom is not unique to our site and so others may benefit from an answer.
I am trying to use Application.CountIf() in an Excel macro and it is not returning a count. It returns the number as 0.
I find this confusing because I have used Application.CountIf() several times in another macro.
Working code from other macro:
Sub newer_COA()
Sheets("BATCH NUMBERS").Select
'Count total of column CO
count = Application.CountIf(Columns(93), "1")
End Sub
Code of new macro - sum_litres()
Sub sum_litres()
Workbooks("Small Fill.xlsm").Activate
Sheets("Small Fill").Select
'Count total Machine one entries in column F
Dim Machine_one_count As Integer
Machine_one_count = Application.CountIf(Columns(6), "1")
Workbooks("Small Fill Analysis.xlsm").Activate
Sheets("Sheet1").Select
Msg = Machine_one_count & " Number of entries from Machine one"
MsgBox Prompt:=Msg
End Sub
Output from new macro - sum_litres()
0 Number of entries from Machine one
I'm creating this new macro sum_litres() in a separate sheet called Small Fill Analysis which gets the sheet Small Fill.xlsm to look at the data. At the start of sum_litres() it uses the function below to check if the sheet Small Fill.xlsm is open and opens it successfully if the sheet is not already open. As this code works fine I didn't include it in my question above.
'Calls function IsWorkBookOpen() to check if the required spreadsheet is open
Ret = IsWorkBookOpen("Small Fill.xlsm")
If Ret = True Then
Workbooks("Small Fill.xlsm").Activate
Sheets("Small Fill").Select
Else
'Open required spreadsheet
Workbooks.Open FileName:="Small Fill.xlsm", ReadOnly:=True
Sheets("Small Fill").Select
End If
Function IsWorkBookOpen(ByVal FileName As String) As Boolean
Dim TargetWorkbook As Workbook
Dim IteratorWorkbook As Workbook
For Each IteratorWorkbook In Application.Workbooks
If IteratorWorkbook.FullName = FileName Then
Set TargetWorkbook = IteratorWorkbook
End If
Next
If Not TargetWorkbook Is Nothing Then
If TargetWorkbook.ReadOnly Then
IsWorkBookOpen = True
Exit Function
End If
End If
End Function
Many thanks for any suggestions!
I suspect the issue is the location of the macro but the solution is simply to not select things but refer to the ranges directly:
Sub sum_litres()
'Count total Machine one entries in column F
Dim Machine_one_count As Integer
Machine_one_count = Application.CountIf(Workbooks("Small Fill.xlsm").Sheets("Small Fill").Columns(6), "1")
Msg = Machine_one_count & " Number of entries from Machine one"
MsgBox Prompt:=Msg
End Sub
I would like to know if there is a way to remotely deactivate an excel file via vba.
The problem:
My company uses an excel file for sales to provide quotations to the customer. Now when there is an update to our pricing scheme I send a new version of the Excel file to the sales team. The obvious thing that happens next is that they don't use the most current version of the file to give a quote => the customer gets a wrong price.
What I tried so far:
I implemented a time bomb that lets the file expire at a defined date. The problem with this is that updates to the excel file happen irregularly.
What I have in mind:
Once the excel file starts a VBA script queries a web server for the most current version number. If the version number in the currently opening Excel file is lower than the one provided by the server, the file locks up.
Is this something one can realize with Excel and VBA? I could imagine that this causes some problem with Windows Security etc. because it may look like a trojan or virus.
You help is much appreciated!
If you send them an .xlsm file the following code (courtesy of Tom Urtis from "VBA and Macros for Microsoft Excel"), will delete the file, when the chosen date has passed.
Please be careful with this code and always make sure to have a back-up copy saved.
Paste this sub in the "workbook" section of the vba and it is going to execute every single time the file is opened. If the current date is after the chosen date it will delete the file.
Private Sub workbook_open()
If Date > CDate("13.07.16") Then
With ThisWorkbook
.Saved = True
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
End If
End Sub
You can also inspect but not by date, by file version, referring to the cell in which version will be available.
Private Sub workbook_open()
If [A1].value > "v.02.15" Then
With ThisWorkbook
.Saved = True
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
End If
End Sub
Sub ПримерИспользования()
Dim ra As Range: On Error Resume Next
Set ra = GetQueryRange("http://ExcelVBA.ru/", 6)
Debug.Print ra '.Address ' переменная ra содержит ссылку на диапазон ячеек $A$1:$C$15,
' содержащий данные 6-й таблицы главной страницы сайта ExcelVBA.ru
End Sub
Function GetQueryRange(ByVal SearchLink$, Optional ByVal Tables$) As Range
On Error Resume Next: Err.Clear
Dim tmpSheet As Worksheet: Set tmpSheet = ThisWorkbook.Worksheets("tmpWQ")
If tmpSheet Is Nothing Then
Application.ScreenUpdating = False
Set tmpSheet = ThisWorkbook.Worksheets.Add
tmpSheet.Name = "tmpWQ"
tmpSheet.Visible = xlSheetVeryHidden
End If
If tmpSheet Is Nothing Then
msg$ = "Не удалось добавить скрытый лист «tmpWQ» в файл программы"
MsgBox msg, vbCritical, "Невозможно выполнить запрос к сайту": End
End If
tmpSheet.Cells.Delete: DoEvents: Err.Clear
With tmpSheet.QueryTables.Add("URL;" & SearchLink$, tmpSheet.Range("A1"))
If Len(Tables$) Then
.WebSelectionType = xlSpecifiedTables
.WebTables = Tables$
Else
.WebSelectionType = xlEntirePage
End If
.FillAdjacentFormulas = False: .PreserveFormatting = True
.RefreshOnFileOpen = False: DoEvents
.WebFormatting = xlWebFormattingAll
.Refresh BackgroundQuery:=False: DoEvents
If Err = 0 Then Set GetQueryRange = tmpSheet.UsedRange
.Delete: DoEvents
End With
End Function
Change the reference in line 3.
Turn window Locals Window the path ofView \ Locals Window.
Before starting the macro set Toggle Breakpoint (F9) in the line Debug.Print ra '.Address' ra variable contains a reference to a cell range $ A $ 1: $ C $ 15,
Run the macro, and in the window Locals Window selectra \ Value2 - it will be the data from the site.
Now the data from the site will be stored in the variable ra and take them can be similar to the following to change the line to:
Debug.Print ra.Value2(2, 2) 'result: "У вас есть интернет-магазин?"
This code is copied from the site: http://excelvba.ru/code/WebQueryRange
Trying to print the same excel sheet a number of times (e.g 100) with a cell incremented each time (e.g cell 4F).
I tried using
Workbook_BeforePrint
to increment the cell, but it requires interaction with the "select printer" dialog for each printed sheet.
Would it be possible to make something like:
a = getIntegerUserInput()
for i in 1..a
increment 4F with one
print the sheet suppressing the "select printer" dialog
end for
Cheers
Have you selected a default printer?
I used this:
Sub printinc()
For i = 0 To 3
Range("A1").Value = Range("A1").Value + 1
Sheets("Sheet1").PrintOut
Next
End Sub
It printed 4 copies incrementing the value in cell A1 each time without prompting me for settings or printer selection.
To print a sheet, you can use this kind of code (assuming you know on which printer you want to print) using PrintOut:
Sub PrintFile()
Dim curPrinter As String
curPrinter = Application.ActivePrinter
Application.ActivePrinter = "Myprinter"
ActiveWindow.SelectedSheets.PrintOut
Application.ActivePrinter = curPrinter
End Sub
Hence, you can create a loop to increase a cell and print your worksheet with the increment.
By the way, you could do it using Before_print and if you don't want to display the print dialog, you can set Cancel to False while calling the procedure Private Sub Workbook_BeforePrint( Cancel As Boolean) (ref on MSDN)
You can also read this SO thread to prevent displaying the printing dialog: How do you prevent printing dialog when using Excel PrintOut method.
[EDIT] see Seyren's answer for a working solution on what you want. Yet, take care about the performance if you really wanted to loop 100 times.
Private Sub Workbook_BeforePrint(Cancel As Boolean)
'//supress recursion into this event when we print
Application.EnableEvents = False
'//increment
If Not IsNumeric(ActiveSheet.Range("A1").Value) Then ActiveSheet.Range("A1").Value = 0
ActiveSheet.Range("A1").Value = ActiveSheet.Range("A1").Value + 1
'//do a default print
ActiveSheet.PrintOut
Application.EnableEvents = True
'//prevent the default print
Cancel = True
End Sub