I'm completely baffled...this macro looks at a Range, draws a number with Rnd then creates a vlookup to bring back a quote and author every time I open up my workbook (should one apply).
This error just began this evening, but only on today's versions. I am able to open up older versions and run the code just as expected.
Below is "Today's" latest copy and produces the Runtime error, with the break happening on the line defining the string quote:
Private Sub Workbook_Open()
Dim sht As Object
Dim RandNumb As Integer
Dim quote As String
Dim author As String
Dim ws As Worksheet
Set ws = Worksheets("Home")
'Make "Home" Sheet visible and select
ws.Visible = True
'Search for all sheets not named "Home" and hide them
For Each sht In Worksheets
If sht.Name <> "Home" Then
sht.Visible = xlSheetHidden
End If
Next sht
'Create random number, then vlookup based off number
RandNumb = Int((56 - 1 + 1) * Rnd + 1)
quote = Application.WorksheetFunction.VLookup(RandNumb, Sheet3.Range("ba101:bc465"), 2, False)
author = Application.WorksheetFunction.VLookup(RandNumb, Sheet3.Range("ba101:bc465"), 3, False)
If quote <> Empty Then
MsgBox quote & vbNewLine & vbNewLine & " - " & author, vbOKOnly, "Quote of the day"
End If
End Sub
While the version from 2/6 works just fine:
Private Sub Workbook_Open()
Dim sht As Object
Dim RandNumb As Integer
Dim quote As String
Dim author As String
Dim ws As Worksheet
Set ws = Worksheets("Home")
'Make "Home" Sheet visible and select
ws.Visible = True
ws.Select
Range("A1").Select
'Search for all sheets not named "Home" and hide them
For Each sht In Worksheets
If sht.Name <> "Home" Then
sht.Visible = xlSheetHidden
End If
Next sht
'Create random number, then vlookup based off number
RandNumb = Int((56 - 1 + 1) * Rnd + 1)
quote = Application.WorksheetFunction.VLookup(RandNumb, Sheet3.Range("ba101:bc465"), 2, False)
author = Application.WorksheetFunction.VLookup(RandNumb, Sheet3.Range("ba101:bc465"), 3, False)
If quote <> Empty Then
MsgBox quote & vbNewLine & vbNewLine & " - " & author, vbOKOnly, "Quote of the day"
End If
End Sub
These codes look no different to me. Even when I copy the version from 2/6 and put it in "Today's" I continue to receive the error. Help please.
This was solved by #Rory; I had carelessly changed the name of the sheet but not in the code.
Related
My code is fairly simple but a bit puzzling. I might be committing a minor error - pardon my newbie-ness. The Sheets.Add.Name line still gets executed despite having Boolean = True, thus a new worksheet is created with the Sheet# naming convention.
Sharing my code:
Private Sub create_analyst_btn_Click()
Dim strUser As String
Dim DateToday As String
Dim ws As Worksheet
Dim boolFound As Boolean
strUser = newanalyst_form.user_User.Value
For Each ws In Worksheets
If ws.Name Like strUser Then boolFound = True: Exit For
Next
If boolFound = True Then
MsgBox ("User already exists.")
Else
DateToday = Format(Date, "-yyyy-mm-dd")
Sheets.Add.Name = strUser & DateToday
Unload Me
End If
End Sub
I don't see the point of the first If statement and I would refactor your code to the following:
For Each ws In Worksheets
If ws.Name Like "*" & strUser & "*" Then
MsgBox ("User already exists.")
Exit For
Else
DateToday = Format(Date, "-yyyy-mm-dd")
Sheets.Add.Name = strUser & DateToday
Unload Me
End If
Next ws
The logic here is that if the name already exists before calling the subroutine, we would discover this while iterating, display a warning message in an alert box, and exit. Otherwise, the name/date would be added to the sheet.
I am trying to use some Parsing i was able to tweak a little. If I use it in straight VBA in excel, it works fine. However, when I use the same code as a module in VB.NET I get the error in the title on the line of code
ws.Range(vTitles).AutoFilter()
(duh!) I am not sure what is going wrong in the conversion, since I am not a hardcore VB.Net programmer, so I am doing a lot of googling, but not finding much that works. Any ideas on how this could be fixed or do I have to abandon the idea of using this snippet in VB.Net?
Here is the code I am using:
'turned strict off or autofilter per http://www.pcreview.co.uk/threads/autofilter-method-of-range-class-failed.3994483/
Option Strict Off
Imports xl = Microsoft.Office.Interop.Excel
Module ParseItems
Public Sub ParseItems(ByRef fileName As String)
'Jerry Beaucaire (4/22/2010)
'Based on selected column, data is filtered to individual workbooks are named for the value plus today's date
Dim wb As xl.Workbook
Dim xlApp As xl.Application
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As xl.Worksheet, MyArr As Object, vTitles As String, SvPath As String
'Set new application and make wb visible
xlApp = New xl.Application
xlApp.Visible = True
'open workbook
wb = xlApp.Workbooks.Open(fileName)
'Sheet with data in it
ws = wb.Sheets("Original Data")
'Path to save files into, remember the final "\"
SvPath = "G:\MC VBA test\"
'Range where titles are across top of data, as string, data MUST have titles in this row, edit to suit your titles locale
vTitles = "A1:L1"
'Choose column to evaluate from, column A = 1, B = 2, etc.
vCol = xlApp.InputBox("What column to split data by? " & vbLf & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)
If vCol = 0 Then Exit Sub
'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xl.XlDirection.xlUp).Row
'Speed up macro execution
'Application.ScreenUpdating = False
'Get a temporary list of unique values from key column
ws.Columns(vCol).AdvancedFilter(Action:=xl.XlFilterAction.xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True)
'Sort the temporary list
ws.Columns("EE:EE").Sort(Key1:=ws.Range("EE2"), Order1:=xl.XlSortOrder.xlAscending, Header:=xl.XlYesNoGuess.xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xl.Constants.xlTopToBottom, DataOption1:=xl.XlSortDataOption.xlSortNormal)
'Put list into an array for looping (values cannot be the result of formulas, must be constants)
MyArr = xlApp.WorksheetFunction.Transpose(ws.Range("EE2:EE" & ws.Rows.Count).SpecialCells(xl.XlCellType.xlCellTypeConstants))
'clear temporary worksheet list
ws.Range("EE:EE").Clear()
'Turn on the autofilter, one column only is all that is needed
ws.Range(vTitles).AutoFilter()
'Loop through list one value at a time
For Itm = 1 To UBound(MyArr)
ws.Range(vTitles).AutoFilter(Field:=vCol, Criteria1:=MyArr(Itm))
ws.Range("A1:A" & LR).EntireRow.Copy()
xlApp.Workbooks.Add()
ws.Range("A1").PasteSpecial(xl.XlPasteType.xlPasteAll)
ws.Cells.Columns.AutoFit()
MyCount = MyCount + ws.Range("A" & ws.Rows.Count).End(xl.XlDirection.xlUp).Row - 1
xlApp.ActiveWorkbook.SaveAs(SvPath & MyArr(Itm), xl.XlFileFormat.xlWorkbookNormal)
'ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY") & ".xlsx", 51 'use for Excel 2007+
xlApp.ActiveWorkbook.Close(False)
ws.Range(vTitles).AutoFilter(Field:=vCol)
Next Itm
'Cleanup
ws.AutoFilterMode = False
MsgBox("Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!")
xlApp.Application.ScreenUpdating = True
End Sub
End Module
Looks like you need to specify at least one optional parameter. Try this:
ws.Range(vTitles).AutoFilter(Field:=1)
I realize this was closed years ago, but I recently ran into this problem and wanted to add to the solution.
This seems to only work when specifically using the first optional Field parameter. I attempted this fix using the optional VisibleDropDown parameter and still got this error.
ws.Range["A1"].AutoFilter(VisibleDropDown: true); Gives error
ws.Range["A1"].AutoFilter(Field: 1); No error
hope everyone is doing good! I have a quick question concerning excel and sheet names. Currently I have a macro assigned to a forum control button on my template invoice page that when clicked will make a duplicate sheet named after cell E7 (the project name) + the word "Invoice" at the end of it. But since there will be more than one invoice per project, I would like the macro to include some code where if it finds a duplicate name, it will automatically start numbering them from two. So for example, I use the macro to create "Project A Invoice". If I use it again to create another one, I want it to be named "Project A Invoice(2)" automatically instead of giving me an error message. Here's what I have so far:
Sub invoice_export_test()
Dim sName As String
Dim wks As Worksheet
Worksheets("Invoice").Copy after:=Sheets(Worksheets.Count)
Set wks = ActiveSheet
Do While sName <> wks.Name
sName = Range("E7") + " Invoice"
wks.Name = sName
On Error GoTo 0
Loop
Range("C7:D7").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With
ActiveSheet.Shapes.Range(Array("Button 1")).Select
Selection.Delete
Set wks = Nothing
End Sub
Everything after the loop is irrelevant to this question (its there to delete the forum control button and data validation), but I included it just in case. The code is probably messy since I am not too experienced with VBA and used a few tutorials to work this out, so please forgive me for that haha.
Thank you in advanced for your time/help!
Create a couple functions to help yourself out:
Function GetUniqueName(strProject As String) As String
' If this is the first time it's being used, just return it without a number...
If Not SheetNameExists(strProject & " Invoice") Then
GetUniqueName = strProject & " Invoice"
Exit Function
End If
' Otherwise, suffix the sheet name with a number, starting at 2...
Dim i As Long, strName As String
i = 1
Do
i = i + 1
strName = strProject & " Invoice (" & i & ")"
Loop While SheetNameExists(strName)
GetUniqueName = strName
End Function
Function SheetNameExists(strName As String) As Boolean
Dim sh As Worksheet
For Each sh In Worksheets
If StrComp(sh.Name, strName, vbTextCompare) = 0 Then
SheetNameExists = True
Exit Function
End If
Next
End Function
Then you can change your code from:
Dim sName As String
Dim wks As Worksheet
Worksheets("Invoice").Copy after:=Sheets(Worksheets.Count)
Set wks = ActiveSheet
Do While sName <> wks.Name
sName = Range("E7") + " Invoice"
wks.Name = sName
On Error GoTo 0
Loop
To:
Worksheets("Invoice").Copy after:=Sheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = GetUniqueName(Range("E7"))
We have an SSRS report that has a separate worksheet for each division. We run a macro to rename all the worksheets with the division name and then copy specific worksheets to a new workbook to be emailed to the divisions. The problem with the code is that if one of the divisions does not have a worksheet that month the macro errors out with an error of "not in specified range". Is there a way to tell it to ignore missing worksheets if they do not exist this time? Here is the code:
Sheets(Array("AB", "CD", "EF", "GH", "IJ", "KL")).Copy
Sheets("AB").Select
ActiveWorkbook.SaveAs Filename:= _
Path & "Holder Agings " & Today & ".xlsx", FileFormat:=xlOpenXMLWorkbook, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
Thank You!
I agree with Rusan Kax, without a complete block of code it is difficult to produce exactly the code you need. The code below shows two techniques. You should be able to adapt one of them to your requirements.
Option Explicit
Sub Test1()
' Demonstrate CheckWshts(Array) which removes names from the array
' if they do not match the name of a worksheet within the active
' workbook
Dim InxWsht As Long
Dim WshtTgt() As Variant
WshtTgt = Array("AB", "CD", "EF", "GH", "IJ", "KL")
Call CheckWshts(WshtTgt)
For InxWsht = LBound(WshtTgt) To UBound(WshtTgt)
Debug.Print WshtTgt(InxWsht)
Next
End Sub
Sub Test2()
' Demonstrates WorksheetExists(Name) which returns True
' if worksheet Name is present within the active workbook.
Dim InxWsht As Long
Dim WshtTgt() As Variant
WshtTgt = Array("AB", "CD", "EF", "GH", "IJ", "KL")
For InxWsht = LBound(WshtTgt) To UBound(WshtTgt)
If WorksheetExists(CStr(WshtTgt(InxWsht))) Then
Debug.Print WshtTgt(InxWsht) & " exists"
Else
Debug.Print WshtTgt(InxWsht) & " does not exist"
End If
Next
End Sub
Sub CheckWshts(WshtTgt() As Variant)
' * WshtTgt is an array of worksheet names
' * If any name is not present in the active workbook,
' remove it from the array
Dim Found As Boolean
Dim InxWshtActCrnt As Long
Dim InxWshtTgtCrnt As Long
Dim InxWshtTgtMax As Long
InxWshtTgtCrnt = LBound(WshtTgt)
InxWshtTgtMax = UBound(WshtTgt)
Do While InxWshtTgtCrnt <= InxWshtTgtMax
Found = False
For InxWshtActCrnt = 1 To Worksheets.Count
If Worksheets(InxWshtActCrnt).Name = WshtTgt(InxWshtTgtCrnt) Then
Found = True
Exit For
End If
Next
If Found Then
' Worksheet WshtTgt(InxWshtTgtCrnt) exists
InxWshtTgtCrnt = InxWshtTgtCrnt + 1
Else
' Worksheet WshtTgt(InxWshtTgtCrnt) does not exist
WshtTgt(InxWshtTgtCrnt) = WshtTgt(InxWshtTgtMax)
InxWshtTgtMax = InxWshtTgtMax - 1
End If
Loop
' Warning this code does not handle the situation
' of none of the worksheets existing
ReDim Preserve WshtTgt(LBound(WshtTgt) To InxWshtTgtMax)
End Sub
Function WorksheetExists(WshtName As String)
' Returns True is WshtName is the name of a
' worksheet within the active workbook.
Dim InxWshtCrnt As Long
For InxWshtCrnt = 1 To Worksheets.Count
If Worksheets(InxWshtCrnt).Name = WshtName Then
WorksheetExists = True
Exit Function
End If
Next
WorksheetExists = False
End Function
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