The Data
Sheet one will be for data entry. Each row will represent a Service Ticket. Each column will represent data about the service incident such as serial number or model number.
Desired Result
For each row containing data in a particular field (Column A ~ "Ticket Number) Excel will create a new sheet (The service ticket) based on a template and place the data from the corresponding row into the designated cells.
Thank you in advance for any assistance you may be able to provide.
I'll start by saying that you should be careful with this as there is a limit to the number of sheets in a workbook. But here is some code in vb. It should give you the logic to get it done in vba. There will just be some difference in referring to the sheet and maybe cells.
You will need to declare the worksheet that you are reading through
Dim ws As Excel.Worksheet
Set ws = ea.Worksheets(1)
It may start at sheet index 0 so Set ws = ea.Worksheets(0)
Or there is something like Excel.Application.Activsheet
Here is the logic to loop through the rows and check the value of column A.
dim lRow as integer
Do While lRow <= ws.UsedRange.Rows.Count
If ws.Range("A" & lRow).Value <> "" Then Then
'If cell A is not blank we then call the worksheet add function.
'Pass the name you want the worksheet and the page setup arguments.
WorksheetAdd ws.Range("A" & lRow).Value, xlPaperLetter, xlPortrait
ws.name = ws.Range("A" & lRow).Value
End If
lRow = lRow + 1
ws.Range("A" & lRow).Activate
Loop
You will want a worksheetAdd function like this
Private Sub WorksheetAdd(szJobNumber As String, Papersize As XlPaperSize, PageOrientation As XlPageOrientation)
Dim bDisplayAlerts As Boolean
On Error GoTo ErrorHandler
'Add worksheet to workbook.
Set ws = ea.Worksheets.Add
ws.Name = szJobNumber
With ws.PageSetup
.Orientation = PageOrientation
.LeftFooter = "&D"
.CenterFooter = "&A"
.RightFooter = "Page &P of &N"
.Papersize = Papersize
End With
On Error GoTo 0
Exit Sub
ErrorHandler:
If Err.Number = 1004 Then
If MsgBox("There has been an error(#1004). Contact support. Excel is not installed or produced an error. Also, check for default printer.",vbCritical, "Information") = vbOK Then
'Unload frmPTReports
Exit Sub
End If
Else
Err.Raise Err.Number, Err.Source, Err.Description
End If
End Sub
Related
I would like to rename sheets based on the same cell within each sheet. When i run the macro rather than having the cell predefined I would like to use an input box to define what cell the sheets are to be named after. This is what I have so far- currently it works for only cell C8.
Sub RenameSheet()
Dim ws As Worksheet
For Each ws In Worksheets
On Error Resume Next
If Len(ws.Range("C8")) > 0 Then
ws.Name = ws.Range("C8").Value
End If
On Error GoTo 0
If ws.Name <> ws.Range("C8").Value Then
MsgBox ws.Name & " Was Not renamed, the suggested name was invalid"
End If
Next
End Sub
I think this code would help but I cannot get it to run
Set CellID = Application.InputBox("Cell reference to label sheets", Type:=8)
Anyone have help on this?
I suggest the following changes.
Also it would be a good idea to activate the current sheet so the user always automatically selects a cell on the correct sheet.
Option Explicit
Public Sub RenameSheet()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Activate 'so we automatically are on the correct sheet to select a range
Dim CellID As Range
Set CellID = Application.InputBox("Cell reference to label sheets", Type:=8)
If CellID.Count > 1 Then 'check how many cells were selected
MsgBox "Please select only one cell!", vbExclamation
Exit Sub
End If
If Len(CellID.Value) > 0 Then
On Error Resume Next
ws.Name = CellID.Value
'catch the error
If Err.Number <> 0 Then MsgBox ws.Name & " Was Not renamed, the suggested name was invalid"
On Error GoTo 0
Else
MsgBox ws.Name & " Was Not renamed, the suggested name was empty"
End If
Next ws
End Sub
Alternative to select the address once and use the same address on every worksheet.
Option Explicit
Public Sub RenameSheet()
Dim CellID As Range
Set CellID = Application.InputBox("Cell reference to label sheets", Type:=8)
If CellID.Count > 1 Then 'check how many cells were selected
MsgBox "Please select only one cell!", vbExclamation
Exit Sub
End If
Dim NameAddress As String
NameAddress = CellID.Address(External:=False)
Dim ws As Worksheet
For Each ws In Worksheets
If Len(ws.Range(NameAddress).Value) > 0 Then
On Error Resume Next
ws.Name = ws.Range(NameAddress).Value
If Err.Number <> 0 Then MsgBox ws.Name & " Was Not renamed, the suggested name was invalid"
On Error GoTo 0
Else
MsgBox ws.Name & " Was Not renamed, the suggested name was empty"
End If
Next ws
End Sub
This should work for you:
Sub RenameSheet()
Dim ws As Worksheet, CellID As Range
For Each ws In ThisWorkbook.Worksheets
Set CellID = Application.InputBox("Cell reference to label sheets", Type:=8)
Set CellID = ws.Cells(CellID.Row, CellID.Column)
On Error Resume Next
ws.Name = CellID
On Error GoTo 0
If ws.Name <> CellID.Value Then
MsgBox ws.Name & " Was Not renamed, the suggested name was invalid"
End If
Next
End Sub
This code will set your range twice, because the inputbox assumes ActiveSheet, as there's no way to assign the worksheet name to your input range without typing it out.
Therefore, once you type in the cell address, it will utilize the .Row and .Column properties of the inputrange of the activesheet, while assigning them to the correct worksheet since we didn't qualify the worksheet in CellID.Row and CellID.Column.
My code below works perfectly to find a cell on a different worksheet when the string is small, however large text strings pull up an error. I have tried using error handling even just to give a MsgBox rather than open a VBA window when it errors.
Can anyone help, preferably find the cell with many characters or if not possible, put an error handler in to say something like, too large to search.
What the code does, is a have a range of cells with text in each cell. I can click on that cell, or a cell 2 columns to the right, then click the FIND button, to go in the next worksheet to find the exact same cell value. All cells are unique.
Sub Find_Cell()
Dim NA As Worksheet
Set NA = Worksheets("Notes Analysis")
LastRow = NA.Cells(Rows.Count, 2).End(xlUp).Row
On Error Resume Next
If Not Intersect(ActiveCell, Range("G19:G" & LastRow)) Is Nothing Then
Dim value As String 'Declare a string
value = ActiveCell.Offset(, -2) 'Get the value of the selected Cell
Dim ws As Worksheet
'ws is the worksheet from we are searching the value
'You have to change myWorkSheetName for you worksheet name
Set ws = ThisWorkbook.Worksheets("DEBT_SALE_ACTIVITY")
ws.Activate
Dim c As Range 'Declare a cell
Set c = ws.Cells.Find(value, LookIn:=xlValues) 'Search the value
If Not c Is Nothing Then 'If value found
c.Activate 'Activate the cell, select it
Else
MsgBox "Not found" 'shows a message "Not Found"
End If
Else
If Not Intersect(ActiveCell, Range("E19:E" & LastRow)) Is Nothing Then
Dim value2 As String 'Declare a string
value2 = ActiveCell 'Get the value of the selected Cell
Dim ws2 As Worksheet
'ws is the worksheet from we are searching the value
'You have to change myWorkSheetName for you worksheet name
Set ws2 = ThisWorkbook.Worksheets("DEBT_SALE_ACTIVITY")
ws2.Activate
Dim c2 As Range 'Declare a cell
Set c2 = ws2.Cells.Find(value2, LookIn:=xlValues) 'Search the value
If Not c2 Is Nothing Then 'If value found
c2.Activate 'Activate the cell, select it
Else
MsgBox "Not found" 'shows a message "Not Found"
End If
Else
MsgBox "Select an Account Note"
End If 'end the If for if active cell is in our notes
End If 'end the If for if active cell is in Account note
End Sub
To provide an error message indicating the text is too long you could do the following:
Add this after each statement where you assign value its value:
value = ActiveCell.Offset(, -2) 'Get the value of the selected Cell
If Len(value) > 255 Then
MsgBox "Text in cell " & CStr(ActiveCell.Address) & " is too long", vbOKOnly, "Search Text Too Long"
Exit Sub
End If
Also, you might want to change your if...then...else code structure.
Currently your code is operating like this:
If Not Intersect(ActiveCell, Range("G19:G" & LastRow)) Is Nothing Then
do things
exit sub
Else
If Not Intersect(ActiveCell, Range("E19:E" & LastRow)) Is Nothing Then
do things
exit sub
Else
MsgBox "Select an Account Note"
exit sub
Which, based on your comments for your End If's isn't exactly what your message box says. If your first if statement is Account Notes and your second if statement is notes, then a better structure would be the following.
Change this code
Else
If Not Intersect(ActiveCell, Range("E19:E" & LastRow)) Is Nothing Then
To look like this
ElseIf Not Intersect(ActiveCell, Range("E19:E" & LastRow)) Is Nothing Then
Then the statement `MsgBox "Select an Account Note" will be accurate. You also be able to delete one of your End If statements.
Your code will operate like this:
If Not Intersect(ActiveCell, Range("G19:G" & LastRow)) Is Nothing Then
do things
exit sub
ElseIf Not Intersect(ActiveCell, Range("E19:E" & LastRow)) Is Nothing Then
do things
exit sub
Else
MsgBox "Select an Account Note"
exit sub
I am fairly new with Excel vba but have been using access vba for some time now.
I have some code which splits a main file into several other files based on a distinct column in excel
Sub SplitbyValue()
Dim FromR As Range, ToR As Range, All As Range, Header As Range
Dim Wb As Workbook
Dim Ws As Worksheet
'Get the header in this sheet
Set Header = Range("D8").EntireRow
'Visit each used cell in column D, except the header
Set FromR = Range("D9")
For Each ToR In Range(FromR, Range("D" & Rows.Count).End(xlUp).Offset(1))
'Did the value change?
If FromR <> ToR Then
'Yes, get the cells between
Set All = Range(FromR, ToR.Offset(-1)).EntireRow
'Make a new file
Set Wb = Workbooks.Add(xlWBATWorksheet)
'Copy the data into there
With Wb.ActiveSheet
Header.Copy .Range("A8")
All.Copy .Range("A9")
End With
'Save it
Wb.SaveAs ThisWorkbook.Path & "\" & Format(Date, "yyyy.mm.dd") & _
" - " & FromR.Value & ".xls", xlWorkbookNormal
Wb.Close
'Remember the start of this section
Set FromR = ToR
End If
Next
End Sub
This works great for the main sheet, but have to copy multiple tabs and this only captures one sheet. How can I expand this so it copies the other sheets as well into that file?
example:
ColumnA
Id1
Id2
Id3
This creates three files (Id1)(Id2)(Id3) but ignores the other sheets.
Create an encompassing loop and define the worksheet being processed with a With...End With statement. You loop through a For Each...Next Statement using a Worksheet object on the Worksheets collection but I typically use the index of each worksheet.
Sub SplitbyValue()
Dim FromR As Range, ToR As Range, dta As Range, hdr As Range
Dim w As Long, ws As Worksheet, wb As Workbook, nuwb As Workbook
'Get the header in this sheet
Set wb = ActiveWorkbook
For w = 1 To wb.Worksheets.Count
With wb.Worksheets(w)
Set hdr = .Range(.Cells(8, "D"), .Cells(8, Columns.Count).End(xlToLeft))
'Visit each used cell in column D, except the header
Set FromR = .Range("D9")
For Each ToR In .Range(FromR, .Range("D" & Rows.Count).End(xlUp).Offset(1))
'Did the value change?
If FromR <> ToR Then
'Yes, get the cells between
Set dta = .Range(FromR, ToR.Offset(-1)).EntireRow
'Make a new file
Set nuwb = Workbooks.Add(xlWBATWorksheet)
'Copy the data into there
With nuwb.Sheet1
hdr.Copy .Range("A8")
dta.Copy .Range("A9")
End With
'Save it
nuwb.SaveAs ThisWorkbook.Path & "\" & Format(Date, "yyyy.mm.dd") & _
" - " & FromR.Value & ".xls", xlWorkbookNormal
nuwb.Close False
Set nuwb = Nothing
'Remember the start of this section
Set FromR = ToR
End If
Next ToR
End With
Next w
End Sub
I did not set up a full test environment but this should get you heading in the right direction. I've always found it unreliable to depend on ActiveSheet.
Here is a function that will allow you to search for a sheet and goto it by name.
Private Sub loopsheets(strSheetName As String)
iFoundWorksheet = 0
For iIndex = 1 To ea.ActiveWorkbook.Worksheets.Count
Set ws = ea.Worksheets(iIndex)
If UCase(ws.Name) = UCase(strSheetName) Then
iFoundWorksheet = iIndex
Exit For
End If
Next iIndex
If iFoundWorksheet = 0 Then
MsgBox "No worksheet was found with the name RESULTS (this is not case sensetive). Aborting."
End If
Set ws = ea.Worksheets(iFoundWorksheet)
ws.Activate
End Sub
If you want to just loop them all you just need the for loop.
Dim iIndex as Integer
For iIndex = 1 To ea.ActiveWorkbook.Worksheets.Count
Set ws = ea.Worksheets(iIndex)
ws.Activate
'Call your code here.
SplitbyValue
Next iIndex
I'm looking for a VBA Macro to export data to a csv. I found this code
which after some tweaking does a great job. However, when copying from a range, Excel seems to ignore hidden columns while I want the CSV to contain all the columns. Has anyone discovered concise way to code this?
Here is the code I have so far:
Sub ExportListOrTable(Optional newBook As Boolean, Optional willNameSheet As Boolean, Optional asCSV As Boolean, Optional visibleOnly As Boolean)
'Sub CopyListOrTable2NewWorksheet()
'Works in Excel 2003 and Excel 2007. Only copies visible data.
'code source: https://msdn.microsoft.com/en-us/library/dd637097%28v=office.11%29.aspx
'improved by: Tzvi
' - replaced new worksheet with new workbook
'params:
' newBook: To create a new new sheet in the current workbook or (default) in a new workbook
' willNameSheet: To offer the user to name the sheet or (default) leave the default names
' asCSV: not implemented - will always save as CSV
' visibleOnly: to filter out any hidden columns - default false
'TODO
' -add parameter list for following options:
' - if table was not selected, copy activesheet.usedRange
' - optional saveFileType
' -
Dim New_Ws As Worksheet
Dim ACell, Data As Range
Dim CCount As Long
Dim ActiveCellInTable As Boolean
Dim CopyFormats, retrySave As Variant
Dim sheetName, user, defaultFileName, fileSaveName As String
Dim userChoice As Boolean
'Check to see if the worksheet or workbook is protected. TODO this may not be necessary anymore
If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
MsgBox "This macro will not work when the workbook or worksheet is write-protected."
Exit Sub
End If
'Set a reference to the ActiveCell. You can always use ACell to
'point to this cell, no matter where you are in the workbook.
Set ACell = activeCell
'Test to see if ACell is in a table or list. Note that by using ACell.ListObject, you
'do not need to know the name of the table to work with it.
On Error Resume Next
ActiveCellInTable = (ACell.ListObject.Name <> "")
On Error GoTo 0
'TODO here we will select the fields to export
'If the cell is in a list or table run the code.
If ActiveCellInTable = True Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
If visibleOnly = True Then
'Test if there are more than 8192 separate areas. Excel only supports
'a maximum of 8,192 non-contiguous areas through VBA macros and manual.
On Error Resume Next
With ACell.ListObject.ListColumns(1).Range 'TODO remove this "with"
CCount = .SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
End With
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 individual areas, so it is not possible to " & _
"copy the visible data to a new worksheet. Tip: Sort your " & _
"data before you apply the filter and try this macro again.", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
Else
'Copy the visible cells.
ACell.ListObject.Range.Copy
End If
Else
'The user indicated he wants to copy hidden columns too.
'**********************************************************
'HOW DO I PROPERLY IMPLEMENT THIS PART?
'**********************************************************
MsgBox ("You wanted to copy hidden columns too?")
ActiveSheet.UsedRange.Copy
End If
Else
' MsgBox "Select a cell in your list or table before you run the macro.", _
' vbOKOnly, "Copy to new worksheet"
userChoice = MsgBox("A Table/Table protion is not selected. Do you want to export the entire page?", vbYesNo)
If userChoice = False Then Exit Sub
ActiveSheet.UsedRange.Copy
'Exit Sub
End If
'Add a new Worksheet/WorkBook.
If newBook = False Then
Set New_Ws = Worksheets.Add(after:=Sheets(ActiveSheet.Index))
Else
Set New_Ws = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
End If
'Prompt the user for the worksheet name.
If willNameSheet = True Then
sheetName = InputBox("What is the name of the new worksheet?", _
"Name the New Sheet")
On Error Resume Next
New_Ws.Name = sheetName
If Err.Number > 0 Then
MsgBox "Change the name of sheet : " & New_Ws.Name & _
" manually after the macro is ready. The sheet name" & _
" you typed in already exists or you use characters" & _
" that are not allowed in a sheet name."
Err.Clear
End If
On Error GoTo 0
End If
'Paste the data into the new worksheet.
With New_Ws.Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValuesAndNumberFormats
.Select
Application.CutCopyMode = False
End With
Application.ScreenUpdating = False
'If you did not create a table, you have the option to copy the formats.
If ActiveCellInTable = False Then
Application.Goto ACell
CopyFormats = MsgBox("Do you also want to copy the Formatting?", _
vbOKCancel + vbExclamation, "Copy to new worksheet")
If CopyFormats = vbOK Then
ACell.ListObject.Range.Copy
With New_Ws.Range("A1")
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
'Select the new worksheet if it is not active.
Application.Goto New_Ws.Range("A1")
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Now we're ready to save our new file as excel format
defaultFileName = ActiveWorkbook.Name
user = Environ("userprofile")
'marker getfilename: to return to if we need to look for a new filename
getfilename:
ChDir user & "\Desktop"
fileSaveName = Application.GetSaveAsFilename(defaultFileName & ".csv", "Comma Delimited Format (*.csv), *.csv")
If fileSaveName <> "False" Then
'error handling for 'file already exists and the user clicks 'no'
On Error Resume Next
ActiveWorkbook.SaveAs fileName:=fileSaveName, FileFormat:=xlCSV, ReadOnlyRecommended:=True, CreateBackup:=False, ConflictResolution:=xlUserResolution
If Err.Number = 1004 Then
'Offer user two options: To try a different filename or cancel the entire export
retrySave = MsgBox(Err.Description, vbRetryCancel, "Error creating file")
If retrySave = vbRetry Then
GoTo getfilename
Else
GoTo cancelprocedure
End If
End If
On Error GoTo 0
Else
GoTo cancelprocedure
End If
Exit Sub
cancelprocedure:
ActiveWorkbook.Close saveChanges:=False
Exit Sub
End Sub
Update:
In response to shagans concern. The parameter list on line one is intended to be set by another Macro as such:
Sub ExportVisibleAsCSV
Call ExportListOrTable(newBook:=True, willNameSheet:=False, asCSV:=True, visibleOnly:=True)
End Sub
Updating now that example code is available:
Ok looking at the code you posted, I see a bool named visibleOnly but I don't see where it gets set. Your ability for the logic to reach UsedRange.Copy entirely depends on that being set to false. The comment above ACell.ListObject.Range.Copy indicates that if you reach that statement you are only copying visible cells. In order to copy the hidden cells, visibleOnly would need to be set to false (bypassing the rest of the CCount stuff). So I would be interested in knowing how that bool is set and checking to see what its value is set to when you are running your code.
Update 2:
You need to set the value of your visibleOnly boolean somehow.
here's some code I edited that creates a message box that allows the user to say "yes" or "no" to "do you want to copy hidden data too?" that answer will dictate the value of visibleOnly which in turn dictates which flow they enter.
In addition to that, your assumption that ACell.ListObject.Range.Copy would only copy visible cells appears to have been incorrect. Instead that is being replaced with the specialcell type for visible cells.
Finally, vbYesNo does not actually return a boolean value. Instead it returns vbYes or vbNo which are vb type enumerators (value 6 and 7 respectively). So setting a bool to the value of a vbYesNo will always return True (as a value exists and essentially it just evaluates iferror).
So I changed that bit as well so it now properly checks the Yes/No condition on your userchoice (which is no longer a bool).
here's the code:
Dim ACell, Data As Range
Dim CCount As Long
Dim ActiveCellInTable As Boolean
Dim CopyFormats, retrySave As Variant
Dim sheetName, user, defaultFileName, fileSaveName As String
'Check to see if the worksheet or workbook is protected. TODO this may not be necessary anymore
If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
MsgBox "This macro will not work when the workbook or worksheet is write-protected."
Exit Sub
End If
'Set a reference to the ActiveCell. You can always use ACell to
'point to this cell, no matter where you are in the workbook.
Set ACell = ActiveCell
'Test to see if ACell is in a table or list. Note that by using ACell.ListObject, you
'do not need to know the name of the table to work with it.
On Error Resume Next
ActiveCellInTable = (ACell.ListObject.Name <> "")
On Error GoTo 0
'TODO here we will select the fields to export
'If the cell is in a list or table run the code.
If ActiveCellInTable = True Then
CopyHidden = MsgBox("Would you like to copy hidden data also?", vbYesNo, "Copy Hidden Data?")
If CopyHidden = vbYes Then
visibleOnly = False
ElseIf CopyHidden = vbNo Then
visibleOnly = True
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
If visibleOnly = True Then
'Test if there are more than 8192 separate areas. Excel only supports
'a maximum of 8,192 non-contiguous areas through VBA macros and manual.
On Error Resume Next
With ACell.ListObject.ListColumns(1).Range 'TODO remove this "with"
CCount = .SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
End With
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 individual areas, so it is not possible to " & _
"copy the visible data to a new worksheet. Tip: Sort your " & _
"data before you apply the filter and try this macro again.", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
Else
'Copy the visible cells.
ACell.ListObject.Range.SpecialCells(xlCellTypeVisible).Copy
' Only visible cells within the table are now in clipboard
End If
Else
'The user indicated he wants to copy hidden columns too.
MsgBox ("You wanted to copy hidden columns too?")
ACell.ListObject.Range.Copy
' All table data cells including hidden are now in clipboard
End If
Else
' MsgBox "Select a cell in your list or table before you run the macro.", _
' vbOKOnly, "Copy to new worksheet"
userChoice = MsgBox("A Table/Table protion is not selected. Do you want to export the entire page?", vbYesNo)
If userChoice = vbNo Then Exit Sub
ActiveSheet.UsedRange.Copy
'Entire sheet range is now in clipboard (this is not always accurate)
'Exit Sub
End If
Assign the Value of the range to your target range instead of using the .Copy method:
Sub ExportCSV(source As Range, filename As String)
Dim temp As Workbook
Set temp = Application.Workbooks.Add
Dim sheet As Worksheet
Set sheet = temp.Worksheets(1)
Dim target As Range
'Size the target range to the same dimension as the source range.
Set target = sheet.Range(sheet.Cells(1, 1), _
sheet.Cells(source.Rows.Count, source.Columns.Count))
target.Value = source.Value
temp.SaveAs filename, xlCSV
temp.Close False
End Sub
This also has the benefit of not nuking whatever the user might have on the clipboard.
I have an excel workbook in excel 2007 which has approx 110 separate worksheets.
I want to have a menu page where the user can say yes or no to the title of the worksheet they want and press a button to run a macro which will then select the worksheets which the user has said Y too and then print them to PDF as one single PDF and not loads of individual PDFs.
I currently have the following code which selects the worksheets and prints them. At present though when I select a PDF printer it prints but only to multiple PDFs and not one single PDF.
Sub Printselection()
Dim rng As Range
Dim wks As Worksheet
For Each rng In Sheets("RA Database").Range("Q6:Q119")
If Trim(rng.Value) <> "" Then
On Error Resume Next
Set wks = Nothing
Set wks = Sheets(rng.Value)
On Error GoTo 0
If wks Is Nothing Then
MsgBox "Sheet " & rng.Value & " does not exist"
Else
Application.Dialogs(xlDialogPrinterSetup).Show
wks.PrintOut
End If
End If
Next rng
End Sub
The hard copy I'm happy for it to work like this but we need for the PDF copy to collate.
I'm a VB newbie so any help really would be appreciated!!
In order to print all the sheets into on PDF file, you will need to store all the sheet names you want to print into an array and then use the following command.
Worksheets(printSheets).PrintOut Preview:=False, ActivePrinter:="Adobe PDF", PrintToFile:=True, PrToFileName:=PSFileName
where printSheets is the array holding the names of sheets you want to print
EDIT:
This will work for you
Sub Printselection()
Dim rng As Range
Dim wks As Worksheet
Dim arr() As String
Dim i As Long: i = 0
For Each rng In Sheets("RA Database").Range("Q6:Q119")
If Trim(rng.Value) <> "" Then
On Error Resume Next
Set wks = Nothing
Set wks = Sheets(rng.Value)
On Error GoTo 0
If wks Is Nothing Then
MsgBox "Sheet " & rng.Value & " does not exist"
Else
ReDim Preserve arr(i)
arr(i) = wks.Name
i = i + 1
End If
End If
Next rng
Dim printSheets As Variant
printSheets = arr
Worksheets(printSheets).PrintOut Preview:=False, ActivePrinter:="Adobe PDF", PrintToFile:=True, PrToFileName:=PSFileName
End Sub