I'm trying to write code to have several Sheets in a file printed in one print job.
The Sheets to be printed are created dynamically; their names and the number of sheets differ each time, but I know that I want to print all sheets in the workbook apart from Keep1 and Keep2 (In real 7 different sheet names).
The reason I want to print all sheets in one job is that it could be many sheets, and this would mean a long wait and lots of print job pop-ups.
To realize the above, I thought of creating a selection of the sheets I want to print and then order to print.
I wrote the following:
Sub printtest()
Dim arr As Variant, sht As Worksheet
arr = Array("Keep1", "Keep2")
Application.DisplayAlerts = False
For Each sht In ThisWorkbook.Worksheets
If Not UBound(Filter(arr, sht.Name, True, vbtruecompare)) >= 0 Then
With sht.PageSetup
.Zoom = False
.FitToPagesWide = 1
End With
sht.Select False
End If
Next sht
SelectedSheets.PrintOut
Application.DisplayAlerts = True
End Sub
After running the code, I run into the following:
sht.Select False adds up each Sheet meeting the conditions to the current selection, but since the button is on active sheet Keep1 this sheet is part of the selection (and should not be):
The .FitToPagesWide = 1 is performed for each Sheet in the selection, but .FitToPagesTall is also set to 1 (I want to keep this as Automatic, but don't know how to.
I don't know how to reference the selection in my print job properly.
I tried:
sht.PrintOut which results in Run-time error 91 (Object variable or With block variable not set).
SelectedSheets.PrintOut which results ion Run-time error 424 (Object required).
My vba knowledge is limited and I can't find a way to reference the selected pages for the printout.
Thanks for looking into this and explaining what is wrong in this approach.
Print Multiple Worksheets
You rarely need to select anything which is shown in the following code.
It writes the worksheet names to the keys of a dictionary, which are actually an array, and uses this array (the keys) to reference the worksheets to be printed.
Sub PrintTest()
Dim Exceptions() As Variant: Exceptions = Array("Keep1", "Keep2")
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Application.DisplayAlerts = False
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
With ws.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 2
End With
dict.Add ws.Name, Empty
End If
Next ws
ThisWorkbook.Worksheets(dict.Keys).PrintOut
Application.DisplayAlerts = True
End Sub
You could try to make a string with only the worksheet names you want, excluding Keep1 and Keep2. Then take that string into an unidimensional array and use that array as your selection of worksheets:
Dim wk As Worksheet
Dim StringWk As String
Dim ArrayWk As Variant
'string of wk names
For Each wk In ThisWorkbook.Worksheets
If wk.Name <> "Keep1" And wk.Name <> "Keep2" Then StringWk = StringWk & wk.Name & "|"
Next wk
StringWk = Left(StringWk, Len(StringWk) - 1) 'clean last | delimiter in string
ArrayWk = Split(StringWk, "|")
Sheets(ArrayWk).Select
'code to print to pdf or whatever
'
'
'
'
'
Sheets("Keep1").Select 'deactivate selection
Erase ArrayWk
To create the array we use SPLIT:
Split
function
Related
Want to be able to click a button on excel that will run a macro that will delete prior sheet named DATA and allow importing an existing sheet from different workbook on to active workbook. There is a slight pop up of the other workbook which I'm not sure how to not allow it to show up. Then I want Data worksheet to be after Dashboard worksheet. From there I want a specific column from that data, Total, to only show values greater than 1. Finally split those values from total to two seperate columns, B and P. B will have values 28 and higher while P will have values of equal to 28 or less than. Here is what I have so far. Thank you!
Edit: I went ahead and modified. I have left it at once DATA sheet has been imported. I would like it to filter the following numerical values from the column that is named Total and only show values greater than 1. After that's been filtered, create two columns right next to "Total" named "p" and "b". The values from DATA column greater than 28 will be in "b" while less or equal to 28 will be in "p". Thank you so much!
Option Explicit
Sub DATA()
Dim ws As Worksheet 'Dim, dimension. Declare variable to be used later
On Error Resume Next 'Continues executing statement, ignores error
Application.DisplayAlerts = False 'Set to false to suppres prompts
Sheets("DATA").Delete
Application.DisplayAlerts = True
On Error GoTo 0 'Disables any error trapping currently present in the procedure
Dim fName As Variant, wb As Workbook 'Variant data type can be used to define variables that contain any type of data
Application.EnableEvents = False 'Disable events to avoid workbooks_open to be started
fName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*") 'fname, file with excel file ext
On Error Resume Next 'Continues executing statement, ignores error
If fName = False Then 'False, exit, msg will show
MsgBox ("No Data selected!")
Exit Sub
End If
On Error GoTo 0
Set wb = Workbooks.Open(fName)
wb.Sheets(1).Copy before:=ThisWorkbook.Sheets(2) 'Importing data from first sheet on to this wb, second location
ActiveSheet.Name = "DATA" 'Naming the sheet DATA
wb.Close False 'Close workbook
Application.EnableEvents = True
Dim SelRange As Range
Dim ColNum As Integer
ColNum = Application.WorksheetFunction.Match("Total ", 0)
ActiveSheet.AutoFilter Field:=16, Criteria1:=">1", _
Operator:=xlAnd
'...?
End Sub
Either you have more then one sheets in the workbook you open.
Then you need to number your "DATA" sheets => DATA_01, DATA_02, ...
Or you have only one DATA Sheet. Then there is no need to loop!
Your B and P, <28 and >28 is not clear. I have realized two variants to filter and copy which should help you to realize your solution.
Option Explicit
Sub DATA()
'Clicking button will delete worksheet DATA prior to adding a new one
Dim ws As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Sheets("DATA").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Dim fName As Variant, wb As Workbook
'Disable events to avoid workbooks_open to be started
Application.EnableEvents = False
'This will allow screen to pop up and choose file
fName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*")
On Error Resume Next
If fName = False Then
MsgBox ("No workbook selected!")
Exit Sub
End If
On Error GoTo 0
Set wb = Workbooks.Open(fName)
wb.Sheets(1).Copy before:=ThisWorkbook.Sheets(3)
ActiveSheet.Name = "DATA"
wb.Close False
Application.EnableEvents = True
'Where do you want to copy the values to?
'New sheet "COPY"?
'On Error Resume Next
'Application.DisplayAlerts = False
'Sheets("COPY").Delete
'Application.DisplayAlerts = True
'On Error GoTo 0
'Worksheets.Add(before:=Sheets(4)).Name = "COPY"
'
'??? Finally split those values from total to two sperate columns, B and P.
'??? B will have values 28 and higher while P will have values of equal to 28 or less than.
'??? value 28 shall be in both groups?
'Define Criterias: Title + Condition
With Sheets("DATA")
.Range("F1").Value = "Value" 'Range("P1").Value
.Range("F2").Value = ">1"
.Range("G1").Value = "Value" 'Range("P1").Value
.Range("G2").Value = "<29"
End With
Sheets("DATA").Range("H:Z").Delete
Sheets("DATA").Range("I1").Value = "values >1 and <29"
Sheets("Data").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("DATA").Range("F1:G2"), _
CopyToRange:=Sheets("DATA").Range("I2"), _
Unique:=True
'Define Criterias: Title + Condition
Sheets("DATA").Range("F4").Value = "Value" 'Range("P1").Value
Sheets("DATA").Range("F5").Value = ">28"
Sheets("DATA").Range("N1").Value = "values >28"
Sheets("Data").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("DATA").Range("F4:F5"), _
CopyToRange:=Sheets("DATA").Range("N2"), _
Unique:=True
End Sub
Solve your task with a formula:
You could add a formula for column "p" and "b"? Of cause you can add this formula also with vba.
Formulara in "p"
=IF(B6<=28,B6,"") or =IF([#Total]<=28,[#Total],"")
Formula in "b"
=IF(B12>28,B12,"") or =IF([#Total]>28,[#Total],"")
Scenario: I have two workbooks, one of them contains VBA (WB1) code and the other (WB2) contains calls to an API for data collection (e.g. Bloomberg Add in function). When the code in WB1 is run, it starts a loop of identifiers, for each, it opens an instance of WB2, and tries to recalculate all functions. Once that is done, it copies some of the data of WB2 to WB1, saves WB2 with the identifier name, closes it and moves on to the next identifier.
Issue: As each of the API calls in WB2 take some time to process ad retrieve data, the VBA script does not wait for the functions to be calculated, it just copies the same data and moves on in the loop. Consequently, the data copied to WB1 is incorrect.
What was tried so far: I used a series of Calculate commands in VBA, also used loops to with DoEvents and tried to set up a counter in WB2 with the number of cells with data still pending calculation. In all these cases, the functions are still not fully calculated.
Obs. In this case, as this is not a specific problem to a single API (e.g. Bloomberg) the solution needs to come from a VBA command in the script of WB1.
Code so far:
Private Sub DownloadData()
Application.ScreenUpdating = True
Application.DisplayAlerts = True
' clear raw data sheets
Dim mainwb As Workbook
Set mainwb = ThisWorkbook
ThisWorkbook.Worksheets(wsRawClassData.Name).UsedRange.ClearContents
Dim wsas As Variant
wsas = Evaluate(ThisWorkbook.Names("WSATickers").Value)
' path
Dim xlsPath As String
xlsPath = Evaluate(ThisWorkbook.Names("Path").Value)
If xlsPath = "" Then
xlsPath = ThisWorkbook.Path
End If
Dim c As Integer
For c = 1 To 100
If wsas(c, 1) = "" Then Exit For
Dim objXL
Set objXL = CreateObject("Excel.Application")
Dim objXLWB
Set objXLWB = Workbooks.Open(xlsPath & "WB2.xlsm")
objXLWB.Worksheets("Data").Range("Identifier").Value = wsas(c, 1)
Application.Calculation = xlManual
Application.Calculation = xlAutomatic
'wait for initial calculations
Do While objXL.CalculationState <> xlDone
DoEvents
Loop
' Recalculation forcing:
objXLWB.Activate
Application.Calculation = xlManual
Application.Calculation = xlAutomatic
Application.CalculateFull
Application.Calculation = xlAutomatic
Dim wsobj As Variant
For Each wsobj In objXLWB.Worksheets
wsobj.Calculate
Do While objXLWB.Worksheets("Data").Range("calcpend").Value <> 0
Application.Wait (Now + TimeValue("0:00:02"))
Loop
Next wsobj
Application.Calculation = xlAutomatic
mainwb.Activate
Do Until objXLWB.Worksheets("Data").Range("calcpend").Value = 0
DoEvents
Loop
ThisWorkbook.Worksheets(wsRawData.Name).Range("A" & (c + 1)).Value = wsas(c, 1)
' save, close, quit
objXLWB.SaveAs Filename:=xlsPath & wsas(c, 1) & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
objXLWB.Close
objXL.Quit
Next c
End Sub
It has been a while (like 20 years) since I worked with VBA and Bloomberg, but as I recall, you can make calls to the Bloomberg API directly from VBA. A quick google search of "call bloomberg api from vba" led me to this page that seems promising:
https://github.com/tebbb/VBA-Bloomberg-API-Wrapper
The solution below takes the following approach.
make a copy of the formulas in all the cells you need to wait on
clear those cells so their values are empty strings
replace the formulas causing them to need to be recalculated
use application.onTime to check every second to see if all formulas have received values
This approach assumes that the formulas that rely on add-ins to fetch data will return not return a value until they have received thier data. If this is not true, you'll need to adjust the code accordingly.
I think the key making this work for you is the use of application.onTime becuase that allows all VBA to finish running which seems to be important to allow the data to be fully retrieved.
Option Explicit
Dim formulas As New Collection
Sub wait_until_filled()
Dim x As Long
Dim range_to_check As range
Dim sheet_to_check As Worksheet
Dim workbook_to_check
Dim cell As range
' specify the workbook that holds the formulas that we want to check
Set workbook_to_check = Workbooks("Book3.xlsx")
' specify the sheet that holds the formulas that we want to check
Set sheet_to_check = workbook_to_check.Worksheets("Sheet1")
' specify the set of cells that contain the formulas we are waiting for.
Set range_to_check = sheet_to_check.range("D1:D2,E1")
' clear out old formulas in case we have had a prior run
Do Until formulas.Count = 0
formulas.Remove 1
Loop
' remember each formula, then clear it
For Each cell In range_to_check
formulas.Add Array(workbook_to_check.Name, sheet_to_check.Name, cell.Address, cell.Formula)
cell.Formula = ""
Next
' replace the formulas, causing them to recalculate
For x = 1 To formulas.Count
Workbooks(formulas(x)(0)).Worksheets(formulas(x)(1)).range(formulas(x)(2)).Formula = formulas(x)(3)
Next
'wait a second then call the sub that checks to see if the data has returned
Application.OnTime DateAdd("s", 1, Now), "wait_for_data"
End Sub
Sub wait_for_data()
Dim x As Long
'check to see of all formulas have a value
For x = 1 To formulas.Count
' this if statement assumes that a formula that relies on an addin will produce
' a blank value until it has been filled in, which may not be true.
If Workbooks(formulas(x)(0)).Worksheets(formulas(x)(1)).range(formulas(x)(2)).Value = "" Then
'we have found a cell that has not updated, check again in another second
Application.OnTime DateAdd("s", 1, Now), "wait_for_data"
Exit Sub
End If
Next
' put code here to execute once all cells have received thier values
MsgBox "all cells have received thier values"
End Sub
I have a folder in that will receive 30 files every day and the file contains multiple sheets and in those sheets, some header starts with Row 1 and some with Row 5. I need apply freeze based on the row header name and I need to run the macro from outside of the folder.
After applying freeze I need to automate the process to send the files to the client.
I tried with below but getting error
"type mismatch souceVBAProject"
Sub FreezePanes()
Call freeze("*.xlsx", "no")
End Sub
Sub freeze(fileName As String, hide As String)
Dim path As String
Dim srcFile As String
On Error GoTo ErrorHandler
path = "C:\Users\RadhaRani\Desktop\Excel\"
srcFile = fileName
Application.ScreenUpdating = False
Dim rng As Range
Dim wks As Workbook
Set wks = Workbooks.Open(path + srcFile)
Set wks = Application.ActiveSheet
For Each ws In Worksheets
ws.Select
Set rng = ActiveCell
Range("A5").Select '<== set Freeze point here
ActiveWindow.FreezePanes = True
rng.Select
Next
wks.Select
ActiveWorkbook.Save
wks.Close
Set wks = Nothing
'If you have shut off ScreenUpdating, you must turn it back on by placing---Application.ScreenUpdating = True---at the top of the code
The top 5 rows are frozen; Note: use the row below the header row.
Application.Goto Cells(6, 1)
ActiveWindow.FreezePanes = True
I am trying to write a script which will cycle through the worksheets in my workbook and delete the worksheet if the cells directly under the strings "detected", "not detected" and "other" are empty. If there is something entered under any of the three strings the worksheet shouldn't be deleted.
I have some code (below) which will delete the worksheet if a specific cell is empty, but I need to integrate a piece to FIND any of the three strings (if they are there, they will be in column A), and to offset this to check whether the cell below is empty.
Sub DeleteEmptyWorksheets()
Dim MySheets As Worksheet
Application.DisplayAlerts = False
For Each MySheets In ActiveWorkbook.Worksheets
If MySheets.Range(“A1”) = “” Then
MySheets.Delete
End If
Next
Application.DisplayAlerts = True
End Sub
The script will be used in processing COVID19 test results, so if you can help it will be extra karma points!!
Thankyou.
Here's a code that should assist you.
Sub DeleteEmptyWorksheets()
Dim MySheets As Worksheet
Dim rngTest As Range
Dim arTest
Dim blNBFound As Boolean
arTest = Array("detected", "not detected", "other")
Application.DisplayAlerts = False
For Each MySheets In ActiveWorkbook.Worksheets
blNBFound = False
For i = LBound(arTest) To UBound(arTest)
Set rngTest = MySheets.Range("A:A").Find(arTest(i))
If Not rngTest Is Nothing Then
If Len(rngTest.Offset(1, 0)) > 0 Then
blNBFound = True
Exit For
End If
End If
Next i
If blNBFound = False Then MySheets.Delete
Next
Application.DisplayAlerts = True
End Sub
I am using an excel Workbook for programtical generation. Once the workbook is created few of the sheets are having required data and few are blank with default templates only.
I need to delete all sheets having default templates (means no data). I can check specific cell to identify this however need to know how to check for all sheets and then delete sheets one by one.
I am having this piece of code:
Sub TestCellA1()
'Test if the value is cell D22 is blank/empty
If IsEmpty(Range("D22").Value) = True Then
MsgBox "Cell A1 is empty"
End If
End Sub
Try this:
Sub DeleteEmptySheets()
Dim i As Long, ws As Worksheet
' we don't want alerts about confirmation of deleting of worksheet
Application.DisplayAlerts = False
For i = Worksheets.Count To 1 Step -1
Set ws = Worksheets(i)
' check if cell D22 is empty
If IsEmpty(ws.Range("D22")) Then
Sheets(i).Delete
End If
Next
' turn alerts back on
Application.DisplayAlerts = True
End Sub
An alternative implementation using For-Each:
Sub deleteSheets()
Dim wb As Workbook
Dim sht As Worksheet
Set wb = Workbooks("Name of your Workbook")
'Set wb = ThisWorkbook You can use this if the code is in the workbook you want to work with
Application.DisplayAlerts = False 'skip the warning message, the sheets will be deleted without confirmation by the user.
For Each sht In wb.Worksheets
If IsEmpty(sht.Range("D22")) And wb.Worksheets.Count > 1 then
sht.Delete
End If
Next sht
Application.DisplayAlerts = True
End Sub
This mainly serves as a demonstration pf how you can easily loop through worksheets.
As suggested in the comments below by #Darren Bartrup-Cook , the logic according to which the sheets are deleted can and should be modified to not only suit your purposes but to also include safeguards.
Making sure there's always at least one worksheet in the workbook is one of them. This can be ensured in a multitude of ways. I updated my answer to implement one these.