I have some code written to build a list of worksheets in a string based on if the user selects a checkbox to include the sheet in the PDF report. See below:
If CheckBox1.Value = True Then
PDFsheets = "Sheet11"
End If
If CheckBox2.Value = True Then
If PDFsheets = "" Then
PDFsheets = "Sheet13"
Else
PDFsheets = PDFsheets & ",Sheet13"
End If
End If
If CheckBox3.Value = True Then
If PDFsheets = "" Then
PDFsheets = "Sheet2"
Else
PDFsheets = PDFsheets & ",Sheet2"
End If
End If
For example, when all 3 checkboxes are selected, MsgBox PDFsheets shows the result Sheet11, Sheet13, Sheet2
NOW, when I try to do a multiple sheet select I get Run-Time Error 9 - Subscript Out of Range. The different things I've tried include:
ThisWorkBook.Sheets(PDFsheets).Select
ThisWorkBook.Sheets(Array(PDFsheets)).Select
xPDF() = Split(PDFsheets, ",")
ThisWorkBook.Sheets(xPDF).Select
xPDF() = Split(PDFsheets, ",")
ThisWorkBook.Sheets(Array(xPDF)).Select
xPDF() = Split(PDFsheets, ",")
For i = 0 to Application.CountA(xPDF) - 1
Sheets(xPDF(i)).Select
next i
ALSO, for the sake of brevity I have tried all of the above examples with ActiveWorkbook instead of ThisWorkBook. PLUS, I've tried rewriting my string building part to reference the sheets names instead of numbers with all of the examples above. So instead of Sheet11, Sheet13, Sheet2 the result was "Sheet11", "Sheet13, "Sheet2" with the double quotes around the sheets.
I've look at other questions and code examples on here and elsewhere that show this same goal and I'm using the selection line exactly as they have had it and I'm getting the Subscript out of range error. (I've also verified everything is spelled correctly)
Additional Note if I try typing the string value directly in it works - ThisWorkBook.Sheets("Sheet11, Sheet13, Sheet2").Select - However, this doesn't allow me to keep it variable.
Your are building a comma separated string that you must convert into an array. You were very close:
Sub BuildAString()
Dim PDFsheets As String
Dim s As Worksheet
PDFsheets = "Sheet1,Sheet2,Sheet3"
ary = Split(PDFsheets, ",")
Sheets(ary).Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\TestFolder\Book1.pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
End Sub
Note this makes 1 pdf file for all three sheets. You would use a loop if you wanted 3 separate files.Note that there are no spaces inPDFsheets because my worksheet names have no spaces.
Related
I'm writing a script that requires opening a second workbook and running a VLOOKUP in the second workbook. It works perfectly when the filename of the second workbook is "testlookup.xlsx" but when I changed the filename to "hippity hop 1251225253.xlsx", it opens a window that says "Update Values: 1251225253" and then the VLOOKUP fails. How can I get the code to work regardless of the filename?
fpath = Application.GetOpenFilename(, , "Select the CMS All Assets exported CSV")
fname = Dir(fpath)
Workbooks.Open (fpath)
Set openedBook = Application.ActiveWorkbook
Set assetBook = openedBook.Worksheets(1)
ActiveWindow.WindowState = xlMinimized
checkWkbk.Activate
With dupeSheet
'determine last row
lr = .Cells(Rows.count, 1).End(xlUp).Row
'vlookup from C2:CEnd
.Range(.Cells(2, 3), .Cells(lr, 3)).FormulaR1C1 = _
"=VLOOKUP(RC[-2], " & CStr(fname) & "!C1:C2, 2, FALSE)"
End With
If your description of the filenames is correct, the problem is that you're using a file name with space characters in it, which is throwing the VLookup off. You need to put single-quote characters around the file name in the formula, thus:
"=VLOOKUP(RC[-2], '" & CStr(fname) & "'!C1:C2, 2, FALSE)"
I may be off base with this bit, since you said it works when you don't have spaces in the file names, but you should also include the worksheet name in the formula string, so your formula would look more like this:
"=VLOOKUP(RC[-2], '[" & CStr(fname) & "]" & assetBook.name & "'!C1:C2, 2, FALSE)"
Part of what may be happening is you use the ActiveWorkbook to find the workbook you need versus finding the workbook by the correct name. I use the below subroutine for this purpose:
Sub Get_Workbook_Object(sPath As String, wbHolder As Workbook)
Dim wb As Workbook
If Len(sPath) > 0 Then
ThisWorkbook.FollowHyperlink (sPath)
Else
Exit Sub
End If
For Each wb In Workbooks
If wb.FullName = sPath Then
Set wbHolder = wb
Exit Sub
End If
Next
End Sub
To use this code you could add the subroutine to your module and then call it with something like:
Get_Workbook_Object fPath, openedBook
Also Dir() isn't going to return a fullpath, it is only going to return the appropriate filename. For example, it may return "Hippity Hop.xlsx" instead of "C:Users\Hippity Hop.xlsx" where the first part is the actual filepath. You may want to use something like this instead:
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Please select the CMS All Assets exported CSV"
.Show
If .SelectedItems.Count = 1 Then
fpath = .SelectedItems(1)
Else
MsgBox "Please choose at least one file"
Exit Sub
End If
End With
This will return the full path of the file.
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
I'm struggling a bit with CheckSpelling in Excel. I have a merged cell that I want to check, but only this cell. Here's what I'm doing.
ActiveSheet.Unprotect strSheetPassword
Application.DisplayAlerts = False
Set ma = Range("B21").MergeArea
ma.MergeCells = False
Union(Range("B1"), ma(1, 1)).CheckSpelling
ma.MergeCells = True
Application.DisplayAlerts = True
ActiveSheet.Protect strSheetPassword
It's checking the cell I want, but it's also checking the rest of the document. In reading other posts, I got the impression that checking a single cell causes CheckSpelling to check the entire document. This is why I put in the Union with the Range("B1") - B1 contains header text that doesn't have any misspellings and is normally locked, so that users can't change it. But, it is still checking the rest of the sheet! I've tried quite a few variations on this, but it still keeps checking the rest of the sheet.
CONCLUSION
I had been under the impression that it was possible to invoke the CheckSpelling form and have it only check certain cells. Apparently, this isn't true. Instead of building my own form, I should be able to get away with checking the whole sheet each time, although I really don't like that. Thanks for all the feedback!
For a single merged cell:
Sub spell_me()
Dim b As Boolean
b = Application.CheckSpelling(Word:=ActiveCell.Text)
MsgBox b & vbCrLf & ActiveCell.Address & vbCrLf & ActiveCell.Text
End Sub
EDIT#1:
To find the miscreant word, you could Split() the text into individual words and check each word.
If it is enough if the wrong part gets highlighted you can use this:
Sub SpellCheck()
Dim response As Boolean
Dim words As Variant
Dim wordCount As Long
Dim startAt As Long
words = Split(ActiveCell.Text, " ")
'set all of the text to automatic color
ActiveCell.Font.ColorIndex = xlAutomatic
For wordCount = LBound(words) To UBound(words)
response = Application.CheckSpelling(word:=words(wordCount))
If Not response Then
'find out where it is in the text and color the font red
startAt = InStr(ActiveCell.Text & " ", words(wordCount) & " ")
ActiveCell.Characters(Start:=startAt, Length:=Len(words(wordCount))).Font.Color = vbRed
End If
Next
End Sub
I'd like to copy only the data validations from a table called Table1_1 on the worksheet TEMPLATE (Maint.) to a table on another worksheet called TEMPLATE. I have looked at the available topic but none come quite close to what I am looking for.
One of the problems are the table on either of these sheets may end up shifting so when I build this macro I will need to take that into account.
So far what I have is:
Copy the first (and only row) of Table1_1 on worksheet TEMPLATE (Maint.).
Look at cell A3 on worksheet TEMPLATE and get the table it belongs to.
Find the first row of the table found in step 2.
Paste data validations of all columns in the table on the first row.
Repeat steps 3 and 4 for all rows of the table.
The code I have so far:
Dim TotalSheets As Integer
Dim p As Integer
Dim iAnswer As VbMsgBoxResult
' This Dim is supposed to be to add worksheets, for the process _
' of copying the data validations to the new sheets, to a skip _
' list. An array perhaps? Skip any sheets listed in this array?
Dim DNCToShts As ?
' The cell to get the table that it is apart of for copying from _
' the other worksheet, "TEMPLATE (Maint.)"
Dim GetCellsTable_Copy As String
' The cell to get the table that it is apart of for pasting onto _
' the other worksheets.
Dim GetCellsTable_Paste As String
' This is the cell to reference on "TEMPLATE (Maint.)" worksheet _
' to get the table name of, this will always be "Table1_1"
GetCellsTable_Copy = "A3"
' This is the cell to reference on each sheet to get the table name.
GetCellsTable_Paste = "A3"
With Aplication
.DisplayAlerts = False
.ScreenUpdating = False
End With
iAnswer = MsgBox("You are about to copy data validations! Do you _
want to proceed?", vbOKCancel + vbExclamation _
+ vbDefaultButton2 + vbMsgBoxSetForeground + vbApplicationModal, _
"Copying Data Valadations")
' Instead of copying the whole table I just need to copy the first row _
' of data, intending to copy just the data validations portion.
Range("Table1_1").Copy
If iAnswer = vbYes Then
p = 1 To Sheets.Count
If UCase$(Sheets(p).Name) <> DNCToShts
StoreTableName = Range(GetCellsTable_Paste).ListObject.Name
I have created a diagram showing what I am aiming to accomplish with each of my Excel VBA modules. Keep in mind this may not include all details and I am working on Part 1 only.:
The Excel VBA online help has everything needed for you to have done this. Just the help page for Validation object members should be sufficient.
The following routine will copy a validation from one cell to another. You should be able to call it in a double-loop (for target rows and columns). Once you're done testing it out, this should probably be a Private function
Sub CopyValidation(ByRef rngSourceCell As Range, ByRef rngTargetCell As Range)
With rngTargetCell.Validation
.Delete
.Add Type:=rngSourceCell.Validation.Type, _
AlertStyle:=rngSourceCell.Validation.AlertStyle, _
Operator:=rngSourceCell.Validation.Operator, Formula1:=rngSourceCell.Validation.Formula1, Formula2:=rngSourceCell.Validation.Formula2
.ErrorMessage = rngSourceCell.Validation.ErrorMessage
.ErrorTitle = rngSourceCell.Validation.ErrorTitle
.IgnoreBlank = rngSourceCell.Validation.IgnoreBlank
.IMEMode = rngSourceCell.Validation.IMEMode
.InCellDropdown = rngSourceCell.Validation.InCellDropdown
.InputMessage = rngSourceCell.Validation.InputMessage
.InputTitle = rngSourceCell.Validation.InputTitle
.ShowError = rngSourceCell.Validation.ShowError
.ShowInput = rngSourceCell.Validation.ShowInput
End With
End Sub
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