Add VBA Conditional Statement to Loop - vba

So I have this code below that currently works. All of the data is on a tab called "Table" and feed into a tab called "Att A" that gets produced into 100+ pdf files and named based on the value that is in column A in the "Table" tab.
I would like to add a conditional statement to the following code that checks the value in column CH in the "Table" tab and if it is greater than 0 save in one location, if it equals 0 then save in another location. Since there are 100+ lines of data, the value in column A needs to check the value in the same row for column CH.
So the logic goes to column A (Uses this value as the file name), creates a file, and checks column CH to determine which folder to save the file in. How do I add this condition to the following code?
Sub Generate_PDF_Files()
Application.ScreenUpdating = False
Sheets("Table").Activate
Range("A7").Activate
Do Until ActiveCell.Value = "STOP"
X = ActiveCell.Value
Range("DLR_NUM") = "'" & X
Sheets("Att A").Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"L:\Mike89\Sales" & X & ".pdf", Quality:=xlQualityStandard, _IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Sheets("Table").Activate
ActiveCell.Offset(1, 0).Activate
Loop
End Sub

Since your code works, we would typically suggest you post it on Code Review, however you're also looking for some help on a conditional statement.
So a few quick things...
Avoid Select and Activate
Use Descriptive Variable Naming
Always Define and Set References to Worksheets and Workbooks
Never Assume the Worksheet
The conditional itself is very straightforward as shown in the example below, which also incorporates the ideas shared in the links above:
Option Explicit
Sub Generate_PDF_Files()
Dim tableWS As Worksheet
Dim attaWS As Worksheet
Dim filename As Range
Dim checkValue As Range
Dim filepath As String
Const ROOT_FOLDER1 = "L:\Mike89\Sales"
Const ROOT_FOLDER2 = "L:\Mike99\Sales"
Set tableWS = ThisWorkbook.Sheets("Table")
Set attaWS = ThisWorkbook.Sheets("Att A")
Set filename = tableWS.Range("A7")
Set checkValue = tableWS.Range("CH7")
Application.ScreenUpdating = False
Dim dlrNum as Range
set dlrNum = tableWS.Range("DLR_NUM")
Do Until filename = "STOP"
dlrNum = "'" & filename
If checkValue > 0 Then
filepath = ROOT_FOLDER1 & filename
Else
filepath = ROOT_FOLDER2 & filename
End If
attaWS.ExportAsFixedFormat Type:=xlTypePDF, _
filename:=filepath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Set filename = filename.Offset(1, 0)
Set checkValue = checkValue.Offset(1, 0)
Loop
Application.ScreenUpdating = True
End Sub

Related

Using VBA to Import multiple text files with different delimiters

UPDATED CODE AND ISSUES (5/9/2018 1:53PM Eastern)
I am encountering problems trying to import multiple data text files into a fixed worksheet ("Raw Data") using two different delimiters. I am using Application.GetOpenFilename to allow the user to select multiple text files from a folder. The files contain a header row which is semicolon delimited, then several lines of data which is comma delimited. In a single text file, this format can be repeated several times (this is an inspection log file which records and appends data to the same text file for each inspection run, i.e. header line1, some rows of data, header line 2, more rows of data, header line 3, more rows of data, etc.)
I've tried a few approaches to solve this based on other examples I've found on StackOverflow.com but I can't seem to successfully mesh the solutions together to come up with a solution that imports single or multiple text files with two different delimiters within each file. I cannot change the format or content of the original text files, so I can't search and replace different delimiters to a single delimiter.
Here are the remaining issues I'm running into with the attached VBA code:
When importing more than one text file, a blank line is inserted between the files which breaks the .TextToColumns section. It is also asking to replace existing data when importing the second file selected. Is there a more efficient or better way to import data from multiple text files using both commas and semicolons as delimiters?
Within a fixed path on the local hard drive, each new order number creates a new sub-folder to store .txt data files (i.e. C:\AOI_DATA64\SPC_DataLog\IspnDetails\123456-7). Is there a way the user can be prompted to enter a sub-folder name (123456-7) and the VBA script will automatically import all .txt files from this sub-folder, rather than using Application.GetOpenFilename?
Here is a truncated version of one of the data files I'm trying to import. The actual file does not have spaces between the rows of data. I separated them in this example to clearly show each line in the text file.
[StartIspn];Time=04/19/18 12:43:15;User=yeseniar;MachineID=WINDOWS-TEFJCS1;Side=T;DoubleSided;IsOnline=1;IA_Idx=1;SN_Idx=0;IT=0;SPC_Db=1;SPC_Txt=1;TxtFmt=10;E_Rpt=1;D_Img=1;FeedMode=0;
KC17390053F,VIA5F,M North,A8,85.0,45.0,96.0,23.2,9.9,0.0,0.0,0.0,59.0,0.0,0.0,0.0,
KC17390053F,VIA3F,M North,A8,85.0,45.0,96.0,22.3,22.9,0.0,0.0,0.0,59.0,0.0,0.0,0.0,
KC17390053F,FMI1F,S South,A13,12.3,0.0,1.0,3.5,3.5,0.0,0.0,0.0,0.0,0.0,0.0,0.0,
KC17390053F,FMI13F,S South,A13,12.3,0.0,1.0,3.5,3.5,0.0,0.0,0.0,0.0,0.0,0.0,0.0,
[StartIspn];Time=04/19/18 14:28:10;User=yeseniar;MachineID=WINDOWS-TEFJCS1;Side=B;DoubleSided;IsOnline=1;IA_Idx=1;SN_Idx=0;IT=0;SPC_Db=1;SPC_Txt=1;TxtFmt=10;E_Rpt=1;D_Img=1;FeedMode=0;
KC17390066B,VIA5B,M North,A8,70.0,50.0,92.0,-38.8,-3.7,0.0,0.0,0.0,50.0,0.0,0.0,0.0,
KC17390066B,VIA6B,M North,A8,70.0,50.0,93.0,-37.7,-23.6,0.0,0.0,0.0,50.0,0.0,0.0,0.0,
KC17390066B,FMI12B,S South,A13,4140.4,0.0,2.0,3.5,129.6,0.0,0.0,0.0,0.0,0.0,0.0,0.0,
KC17390066B,FMI24B,S South,A13,2128.7,0.0,2.0,3.5,119.1,0.0,0.0,0.0,0.0,0.0,0.0,0.0,
Here is what I have so far for importing multiple text files:
Sub Import_DataFile()
' Add an error handler
On Error GoTo ErrorHandler
' Speed up this sub-routine by turning off screen updating and auto calculating until the end of the sub-routine
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Define variable names and types
Dim OpenFileName As Variant
Dim i As Long
Dim n1 As Long
Dim n2 As Long
Dim fn As Integer
Dim RawData As String
Dim rngTarget As Range
Dim rngFileList As Range
Dim TargetRow As Long
Dim FileListRow As Long
Dim dLastRow As Long
Dim destCell As Range
' Select the source folder and point list file(s) to import into worksheet
OpenFileName = Application.GetOpenFilename( _
FileFilter:="AOI Inspection Results Data Files (*.txt), *.txt", _
Title:="Select a data file or files to import", _
MultiSelect:=True)
' Import user selected file(s) to "Raw Data" worksheet
TargetRow = 0
Set destCell = Worksheets("Raw Data").Range("B1")
For n2 = LBound(OpenFileName) To UBound(OpenFileName)
fn = FreeFile
Open OpenFileName(n2) For Input As #fn
Application.StatusBar = "Processing ... " & OpenFileName(n2)
Do While Not EOF(fn)
Line Input #fn, RawData
TargetRow = TargetRow + 1
Worksheets("Raw Data").Range("B" & TargetRow).Formula = RawData
Loop
Next n2
Close #fn
Set rngTarget = Worksheets("Raw Data").Range("B1" & ":" & Worksheets("Raw Data").Range("B1").End(xlDown).Address)
With rngTarget
.TextToColumns Destination:=destCell, DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=True, Space:=False, Other:=False, OtherChar:="|", _
FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
End With
Else: MsgBox "The selected file is not the correct format for importing data."
Exit Sub
End If
Next
' Create a number list (autofill) in Col A to maintain original import sort order
dLastRow = Worksheets("Raw Data").Cells(Rows.Count, "B").End(xlUp).Row
Worksheets("Raw Data").Range("A1:A" & dLastRow).Font.Color = RGB(200, 200, 200)
Worksheets("Raw Data").Range("A1") = "1"
Worksheets("Raw Data").Range("A2") = "2"
Worksheets("Raw Data").Range("A1:A2").AutoFill Destination:=Worksheets("Raw Data").Range("A1:A" & dLastRow), Type:=xlFillDefault
Worksheets("Raw Data").Range("F1:Q" & dLastRow).NumberFormat = "0.0"
' Auto fit the width of columns for RAW Data
Worksheets("Raw Data").Columns("A:Z").EntireColumn.AutoFit
' Turn screen updating and auto calculating back on since file processing is now complete
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
' Reset to defaults in the event of a processing error during the sub-routine execution
ErrorHandler:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Err.Number <> 0 Then
' Display a message to the user including the error code in the event of an error during execution
MsgBox "An error number " & Err.Number & " was encountered!" & vbNewLine & _
"Part or all of this VBA script was not completed.", vbInformation, "Error Message"
End If
End Sub
Many questions... Let me give some hints.
Prompting the user for working directory :
Dim fDlg As FileDialog ' dialog box object
Dim sDir As String ' selected path
Dim iretval As Long ' test
Set fDlg = Application.FileDialog(msoFileDialogFolderPicker)
sDir = conDEFAULTPATH ' init
With fDlg
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = sDir
iretval = .Show
If iretval = -1 Then sDir = .SelectedItems(1)
End With
Set fDlg = Nothing ' drop object
If sDir = vbNullString Then
MsgBox "Invalid directory"
Else
If Right$(Trim$(sDir), 1) <> Application.PathSeparator Then _
sDir = Trim$(sDir) & Application.PathSeparator' append closing backslash to pathname
End If
Collecting files to a buffer
Dim FileBuf(100) as string, FileCnt as long
FileCnt=0
FileBuf(FileCnt)=Dir(sDir & "*.txt")
Do While FileBuf(FileCnt) <> vbnullstring
FileCnt = FileCnt + 1
FileBUf(FileCnt) = Dir
Loop
Reducing number of delimiters: simply use replace
RawData = Replace(RawData, ";", ",")
For the blank line I have no clue, though it might be a result of a blank line in the source file, maybe the EOF. So what if you check the line before copying:
If len(trim(RawData)) > 0 Then
TargetRow = TargetRow + 1
Worksheets("Raw Data").Range("B" & TargetRow) = RawData
End If
Please note that I've removed .Formula. You are working with values.
For setting target range: You should omit .Address. For selecting last cell in a range, you should use .End(xlUp) this way:
Set rngTarget = Worksheets("Raw Data").Range("B1" & ":" & Worksheets("Raw Data").Range("B1").End(xlUp))
I prefer using direct cell references, so - as you exactly know the last row - I would do it this way:
Set rngTarget = Worksheets("Raw Data").Range(Cells(1, 2), Cells(TargetRow, 2))
Good Luck!

Shorter way to test range for a certain string

Trying to create code that will export my Excel invoice sheet to PDF, to a specified file path. The path is based on the whether the invoice lists a certain product, ProductX.
This is what I came up with, but seems cumbersome to loop through every single cell in a range to see if ProductX is there.
Is there an easier way to do this? Appreciate any help!
Sub ExportToPDF()
'
Dim file_path As String
Dim search_range As Range
Dim each_cell As Range
' Set search_range as desired search range
Set search_range = ActiveSheet.Range("A53:R56")
For Each each_cell In search_range.Cells
If InStr(1, each_cell.Value, "ProductX", vbTextCompare) Then
file_path = Some_path_A
Else: file_path = Some_path_B
End If
Next each_cell
'Export the sheet as PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=file_path, Quality:=xlQualityStandard _
, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
End Sub
You can use Find for a partial match.
This code assumes that the returned path contains the filepath variable you need - you may need to tweak this.
Dim rng1 As Range
Set rng1 = ActiveSheet.Range("A53:R56").Find("ProductX", , xlFormulas, xlPart)
If rng1 Is Nothing Then Exit Sub
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=rng1.Value, Quality:=xlQualityStandard _
, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
Based on what brettdj has suggested, you can use the proposed code like below...
Sub ExportToPDF()
Dim file_path As String
Dim search_range As String
Dim each_cell As Range
Dim rng1 As Range
' Set search_range as desired search range
search_range = ActiveSheet.Range("A53:R56")
Set rng1 = ActiveSheet.Range("A53:R56").Find("ProductX", , xlFormulas, xlPart)
If Not rng1 Is Nothing Then
file_path = Some_path_A
Else
file_path = Some_path_B
End If
'Export the sheet as PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=file_path, Quality:=xlQualityStandard _
, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
End Sub
I think the shortest way is the following:
If WorksheetFunction.CountIf(ActiveSheet.Range("A53:R56"), "*ProductX*") = 0 Then Exit Sub
which can be further reduced to:
If WorksheetFunction.CountIf(Range("A53:R56"), "*ProductX*") = 0 Then Exit Sub
since ActiveSheet is the default ragnge worksheet qualification
There is a way to find exactly that with just a line of code however it will work only the if you search on 1 column. For your case I think it will work because usually the product name will be in a column. The code is as follows:
Dim test As Variant
Product = "ProductX"
' Set search_range as desired search range
search_range = Application.WorksheetFunction.Transpose(Sheets(1).Range("A53:A56"))
If UBound(Filter(search_range, Product)) > -1 Then
file_path = Some_path_A
Else
file_path = Some_path_B
End If
You can give it a try and let me know if this works for you. If not I will try to find a way to do it with multiple columns and improve the answer

Export Excel sheet to PDF using Macros and values of another table

I'm new in Excel Macros and have no experience with VB or any language.
I have a sheet with a Price List, in this we have a field with a dropdown list with Contact Info (mail and cellphone) of our Salesman.
A second sheet contain a table with Name and ContactInfo.
Today, i use the dropdown to choose the salesman and export to pdf to specific directory.
I'm looking to export to PDF using a Macro doing these things. I've tried some macros without success. I want to use the name #Name to save in directory and #ContactInfo to replace in a specific field of pricelist.
What i have:
Sub MAKEPDF()
Dim dvCell As Range
Dim inputRange As Range
Dim c As Range
Dim i As Long
'Which cell has data validation
Set dvCell = Sheets("NUEVA LISTA").Range("A3")
'Determine where validation comes from
Set inputRange = Evaluate(dvCell.Validation.Formula1)
arrVendedores = Array("Name1", "Name2", "Name3", "Name4", "Name5", "Name6", "Name7")
i = 1
'Begin our loop
Application.ScreenUpdating = False
For Each c In inputRange
dvCell = c.Value
ChDir "D:\Google Drive\Lista de Precios\temp\" & arrVendedores(i)
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="(" & Format(Range("A4"), "yyyy-mm-dd") & ") Lista de precios.pdf"
'Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
i = i + 1
Next c
Application.ScreenUpdating = True
End Sub
This save in PDF perfectly but that array don't work as expected causing error 9 (index) and is better use current data from Table1#Name.
Can anyone help me to goal this?
Thanks and sorry for my bad english.
I found it hard to edit your code without seeing some of the inputs, but I got this to flow though with some dummy data.
Sub MAKEPDF()
Dim dvCell As Range
Dim inputRange As Range
Dim c As Range
Dim i As Long
Application.ScreenUpdating = False
'Which cell has data validation
Set dvCell = Sheets("NUEVA LISTA").Range("A3")
'You assigned the value of this cell later on but didn't use it so I removed the value assignment below.
'Determine where validation comes from
Set inputRange = Evaluate(dvCell.Validation.Formula1)
arrVendedores = Array("Name1", "Name2", "Name3", "Name4", "Name5", "Name6", "Name7")
'you might want to assign this in code, not sure if it is the sheet names but I assumed it is if not and just filenames to use.
For i = LBound(arrVendedores) To UBound(arrVendedores)
'this allows an array of any size to be iterated over with having to change the code.
ChDir "D:\Google Drive\Lista de Precios\temp\" & arrVendedores(i)
Worksheets(arrVendedores(i)).ExportAsFixedFormat Type:=xlTypePDF, Filename:="(" & Format(Range("A4"), "yyyy-mm-dd") & ") Lista de precios.pdf"
'you had activeworksheet here but it didn't seem to be changing, so if I assume the array is sheet names this will export those sheet else you will need to change to suit.
'Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
Next
Application.ScreenUpdating = True
End Sub
Thank you Captain, based on your answer i made a new macro as following
Sub MakePDF4()
Dim myTable As ListObject
Dim myArray As Variant
Dim x As Long
Dim vendedorDatos As Range
Dim vendedorCampoDatos As Range
Set myTable = Sheets("VENDEDORES").ListObjects("Table1")
myArray = myTable.DataBodyRange
For x = LBound(myArray) To UBound(myArray)
Application.ScreenUpdating = False
Set vendedorCampoDatos = (Sheets("NUEVA LISTA").Range("A3"))
vendedorCampoDatos = myArray(x, 2)
'ChDir "D:\Google Drive\Lista de Precios\temp\" & myArray(x, 1)
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="D:\Google Drive\Lista de Precios\temp\" & myArray(x, 1) & "\(" & Format(Range("A4"), "yyyy-mm-dd") & ") Lista de precios.pdf"
'Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
Next x
Application.ScreenUpdating = True
End Sub
It work as expected. I have some issue with setting ChDir with the array at the end but works when is setting in filename.
All data is in a unique file (may be i mispelled or confuse some words at explaining). One worksheet is the price list and a second worksheet contains the table with [#Name] and [#ContactInfo] of salesmen.
I use [#Name] to determinate in which directory i will save the PDF file and [#ContactInfo] to change in the worksheet of price list a unique field between salesmen

Can I optimize and speed up my VBA code

I am no VBA guru, but capable enough to stitch together the below code. It essentially formats a Invoice to hide any empty rows (populated with vlookups, but no value returns ""), set to 1 page portrait and export to PDF.
My issue is:
The code is taking way to long to run from start to finish.
Below is the VBA code I want to optimize and speed up.
Sub Save_Quote_As_PDF()
Application.ScreenUpdating = False
Dim a As Long
For a = 1 To ActiveSheet.Shapes.Count
On Error Resume Next
With ActiveSheet.Shapes.Item(a)
.Placement = xlMoveAndSize
.PrintObject = True
End With
Next a
On Error GoTo 0
ActiveSheet.Range("DCANUMBER").SpecialCells(4).EntireRow.Hidden = True
Dim PdfFilename As Variant
PdfFilename = Application.GetSaveAsFilename( _
InitialFileName:=ActiveWorkbook.Path & "\" & ActiveSheet.Range("N2").Value, _
FileFilter:="PDF, *.pdf", _
Title:="Save As PDF")
If PdfFilename <> False Then
With ActiveSheet.PageSetup
.Orientation = xlPortrait
.PrintArea = "$A$1:$K$78"
.PrintTitleRows = ActiveSheet.Rows(19).Address
.Zoom = False
.FitToPagesTall = 1
.FitToPagesWide = 1
End With
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=PdfFilename, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End If
ActiveSheet.Range("DCANUMBER").SpecialCells(4).EntireRow.Hidden = False
Application.ScreenUpdating = True
End Sub
To hide the blank rows:
Dim ws As Worksheet
Set ws = ActiveSheet ' ActiveSheet is of type Object so using type Worksheet is a tiny bit faster
Dim row As Range ' again, specifying the type makes it a tiny bit faster
For Each row In ws.UsedRange.Rows ' .UsedRange to limit the range to only the used range
If row.Find("*") Is Nothing Then
row.EntireRow.Hidden = True
End If
Next
I don't think that hiding the rows is the slowest part of your code. You should time your code to see what parts are the slowest:
Dim start As Single
start = Timer
' part of the code
Debug.Print CDbl(Timer - start), "part 1" ' CDbl to avoid scientific notation
start = Timer ' remember to reset the start time
' another part of the code
Debug.Print CDbl(Timer - start), "part 2"

How to loop through worksheets in a defined order using VBA

I have the below working code which loops through each worksheet and if the value defined in the range (myrange) is 'Y', it outputs those sheets into a single PDF document. My challange is that i want to define the order that they are output in the PDF based on the number value in the range (for example 1,2,3,4,5,6,7 etc) instead of 'Y'. I plan on using the same column in the myrange to check whether it needs to be output to PDF, by simply swapping the 'Y' for a number, such as '1' and '2'.
Currently the order is defined based on the location of the worksheet tabs. from left to right.
Any help will be much appreciated.
Sub Run_Me_To_Create_Save_PDF()
Dim saveAsName As String
Dim WhereTo As String
Dim sFileName As String
Dim ws As Worksheet
Dim printOrder As Variant '**added**
Dim myrange
On Error GoTo Errhandler
Sheets("Settings").Activate
' Retrieve value of 'Period Header' from Settings sheet
Range("C4").Activate
periodName = ActiveCell.Value
' Retrieve value of 'File Name' from Settings sheet
Range("C5").Activate
saveAsName = ActiveCell.Value
' Retrieve value of 'Publish PDF to Folder' from Settings sheet
Range("C6").Activate
WhereTo = ActiveCell.Value
Set myrange = Worksheets("Settings").Range("range_sheetProperties")
' Check if Stamp-field has any value at all and if not, add the current date.
If Stamp = "" Then Stamp = Date
' Assemble the filename
sFileName = WhereTo & saveAsName & " (" & Format(CDate(Date), "DD-MMM-YYYY") & ").pdf"
' Check whether worksheet should be output in PDF, if not hide the sheet
For Each ws In ActiveWorkbook.Worksheets
Sheets(ws.Name).Visible = True
printOrder = Application.VLookup(ws.Name, myrange, 4, False)
If Not IsError(printOrder) Then
If printOrder = "Y" Then
Sheets(ws.Name).Visible = True
End If
Else: Sheets(ws.Name).Visible = False
End If
Next
'Save the File as PDF
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
sFileName, Quality _
:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
' Unhide and open the Settings sheet before exiting
Sheets("Settings").Visible = True
Sheets("Settings").Activate
MsgBox "PDF document has been created and saved to : " & sFileName
Exit Sub
Errhandler:
' If an error occurs, unhide and open the Settings sheet then display an error message
Sheets("Settings").Visible = True
Sheets("Settings").Activate
MsgBox "An error has occurred. Please check that the PDF is not already open."
End Sub
---------------------- UPDATE: -------------------------------------
Thank you for all your input so far. I did get it to work briefly, but with more playing i've become stuck. I am now receiving a 'Subscript our of range' error with the below code at :
If sheetNameArray(x) <> Empty Then
Any ideas?
Sub Run_Me_To_Create_Save_PDF()
Dim saveAsName As String
Dim WhereTo As String
Dim sFileName As String
Dim ws As Worksheet
Dim myrange
ReDim sheetNameArray(0 To 5) As String
Dim NextWs As Worksheet
Dim PreviousWs As Worksheet
Dim x As Integer
'On Error GoTo Errhandler
Sheets("Settings").Activate
' Retrieve value of 'Period Header' from Settings sheet
Range("C4").Activate
periodName = ActiveCell.Value
' Retrieve value of 'File Name' from Settings sheet
Range("C5").Activate
saveAsName = ActiveCell.Value
' Retrieve value of 'Publish PDF to Folder' from Settings sheet
Range("C6").Activate
WhereTo = ActiveCell.Value
' Check if Stamp-field has any value at all and if not, add the current date.
If Stamp = "" Then Stamp = Date
' Assemble the filename
sFileName = WhereTo & saveAsName & " (" & Format(CDate(Date), "DD-MMM-YYYY") & ").pdf"
Set myrange = Worksheets("Settings").Range("range_sheetProperties")
For Each ws In ActiveWorkbook.Worksheets
printOrder = Application.VLookup(ws.Name, myrange, 4, False)
If Not IsError(printOrder) Then
printOrderNum = printOrder
If printOrderNum <> Empty Then
'Add sheet to array
num = printOrderNum - 1
sheetNameArray(num) = ws.Name
End If
End If
Next
MsgBox Join(sheetNameArray, ",")
'Order Tab sheets based on array
x = 1
Do While Count < 6
If sheetNameArray(x) <> Empty Then
Set PreviousWs = Sheets(sheetNameArray(x - 1))
Set NextWs = Sheets(sheetNameArray(x))
NextWs.Move after:=PreviousWs
x = x + 1
Else
Count = Count + 1
x = x + 1
End If
Loop
Sheets(sheetNameArray).Select
'Save the File as PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFileName, Quality _
:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
' open the Settings sheet before exiting
Sheets("Settings").Activate
MsgBox "PDF document has been created and saved to : " & sFileName
Exit Sub
Errhandler:
' If an error occurs, unhide and open the Settings sheet then display an error message
Sheets("Settings").Visible = True
Sheets("Settings").Activate
MsgBox "An error has occurred. Please check that the PDF is not already open."
End Sub
You would want to define the worksheets in an array.
This example uses a static array, knowing the sheets order and what you want to print in advance. This does work.
ThisWorkbook.Sheets(Array("Sheet1","Sheet2","Sheet6","Master","Sales")).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sFileName, Quality _
:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
The problem is that if a sheet is hidden, it will fail on the selection.
So you will need to already know which sheets pass the test to be printed or not before declaring the Array. Therefore you will need a dynamic array to build the list of Worksheets.
I did change how your PrintOrder works, instead of making the sheet invisible, it simply doesn't add it to the array, or vice versa, adds the ones you want to the array. Then you select the array at the end, and run your print macro that works.
I tested this using my own test values, and am trusting that your PrintOrder Test works. But this does work. I used it to print time sheets that only have more than 4 hours per day, and it succeeded, merging 5 sheets out of a workbook with 11 sheets into one PDF.. All of them qualified the test.
TESTED: Insert this instead of your For Each ws and add the Variable Declarations with yours
Sub DynamicSheetArray()
Dim wsArray() As String
Dim ws As Worksheet
Dim wsCount As Long
wsCount = 0
For Each ws In Worksheets
printOrder = Application.VLookup(ws.Name, myrange, 4, False)
If Not IsError(printOrder) Then
If printOrder = "Y" Then
wsCount = wsCount + 1
ReDim Preserve wsArray(1 To wsCount)
'Add sheet to array
wsArray(wsCount) = ws.Name
End If
End If
Next
Sheets(wsArray).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sFileName, Quality _
:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End Sub
edit: further explained context of my code to OP
Here is a bit of code I came up with. Basically you would want to take this and adapt it to fit your specific needs but the general idea should work!
Sub MovingPagesAccordingToNumberInRange()
Dim ws As Worksheet
Dim NextWs As Worksheet
Dim PreviousWs As Worksheet
Dim sheetNameArray(0 To 400) As String
Dim i As Integer
'This first loop is taking all of the sheets that have a number
' placed in the specified range (I used Cell A1 of each sheet)
' and it places the name of the worksheet into an array in the
' order that I want the sheets to appear. If I placed a 1 in the cell
' it will move the name to the 1st place in the array (location 0).
' and so on. It only places the name however when there is something
' in that range.
For Each ws In Worksheets
If ws.Cells(1, 1).Value <> Empty Then
num = ws.Cells(1, 1).Value - 1
sheetNameArray(num) = ws.Name
End If
Next
' This next section simply moves the sheets into their
' appropriate positions. It takes the name of the sheets in the
' previous spot in the array and moves the current spot behind that one.
' Since I didn't know how many sheets you would be using I just put
' A counter in the prevent an infinite loop. Basically if the loop encounters 200
' empty spots in the array, everything has probably been organized.
x = 1
Do While Count < 200
If sheetNameArray(x) <> Empty Then
Set PreviousWs = sheets(sheetNameArray(x - 1))
Set NextWs = sheets(sheetNameArray(x))
NextWs.Move after:=PreviousWs
x = x + 1
Else
Count = Count + 1
x = x + 1
End If
Loop
End Sub