hoping someone can help
I'm trying to call a timeline slicer value in vba so I can control other slicers. I have managed it from cells but I was wondering if it can be controlled by my master slicer
Sub Slicer_Time_Change()
Dim startDate As Date, endDate As Date
startDate = Range("A1") 'Set slicer 1 start date as slicer selection instead
endDate = Range("B1") 'Set slicer 1 End date as slicer selection instead
ActiveWorkbook.SlicerCaches("NativeTimeline_Date1").TimelineState. _
SetFilterDateRange startDate, endDate
ActiveWorkbook.SlicerCaches )("NativeTimeline_Date2").TimelineState. _
SetFilterDateRange startDate, endDate
End Sub
Many thanks in advance!
Going to answer this one myself!
Sub Slicer_Time_Change()
'Gets data from master slicer selection
Set cache = ActiveWorkbook.SlicerCaches("NativeTimeline_Date1")
'Puts into cell
Cells(1, 1) = cache.TimelineState.startDate
Cells(1, 2) = cache.TimelineState.endDate
Dim startDate As Date, endDate As Date
startDate = Range("A1")
endDate = Range("B1")
'Takes data from cell and controls other slicers with date range
ActiveWorkbook.SlicerCaches("NativeTimeline_Date2").TimelineState. _
SetFilterDateRange startDate, endDate
End Sub
I had the same problem. Your answer helped but I needed this triggered when the master slicer changed. Unfortunately slicers have no events, but the PivotTables they impact do. The code below will update all other timeline slicers when the master slicer changes which, in turn, changes its PivotTable, which can then be used to trigger changes to all other slicers.
Private Sub Workbook_SheetPivotTableUpdate(ByVal Sh As Object, ByVal Target As PivotTable)
' Description:Update Timeline Slicers from Master Slicer
' Inputs: Sh PivotTable's worksheet
' Target PivotTable being changed/updated
' Outputs: *None
' Requisites: *None
' Example: *None - This is an event handler found in ThisWorkbook module
' Date Ini Modification
' 10/19/16 CWH Initial Development
' Declarations
Const cRoutine As String = "Workbook_SheetPivotTableUpdate"
Dim oSlicer As SlicerCache 'Current Slicer
Const cSlicer As Long = 1 'Master Slicer
Dim dStartDate As Date 'Start Date
Dim dEndDate As Date 'End Date
Dim bCleared As Boolean 'Filter Cleared Flag
Dim bEvents As Boolean 'Events Enabled Flag
' Error Handling Initialization
On Error GoTo ErrHandler
' Prevent cascading events
bEvents = Application.EnableEvents
Application.EnableEvents = False
' Get Master Slicer's dates
Set oSlicer = ThisWorkbook.SlicerCaches(cSlicer)
bCleared = oSlicer.FilterCleared
If Not bCleared Then
With oSlicer.TimelineState
dStartDate = .FilterValue1
dEndDate = .FilterValue2
End With
End If
' Set All other Timeline Slicer Dates
For Each oSlicer In ThisWorkbook.SlicerCaches
If oSlicer.SlicerCacheType = xlTimeline And _
oSlicer.Index <> cSlicer Then
If bCleared Then _
oSlicer.ClearAllFilters Else _
oSlicer.TimelineState.SetFilterDateRange _
StartDate:=dStartDate, EndDate:=dEndDate
End If
Next
ErrHandler:
Select Case Err.Number
Case Is = 0: 'Do nothing
Case Is = 9: 'Do Nothing Master Slicer Missing
Case Else:
Select Case MsgBox(Prompt:=Err.Description, _
Buttons:=vbAbortRetryIgnore, _
Title:=cRoutine, _
HelpFile:=Err.HelpFile, _
Context:=Err.HelpContext)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
' Clean up: Resume responding to events
Application.EnableEvents = bEvents
End Sub
Option Explicit
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
If Target = "TopElementOfSum" Then
ActiveWorkbook.SlicerCaches("NativeTimeline_Date1").TimelineState.SetFilterDateRange ActiveWorkbook.SlicerCaches("NativeTimeline_Date").TimelineState.StartDate, ActiveWorkbook.SlicerCaches("NativeTimeline_Date").TimelineState.EndDate
'NativeTimeline_Date1 to numer slidera w systemie nie jego nazwa, kiedys dlugo sie z tym jebalem bo nie wiedzialem co jest 5
End If
End Sub
Works for me, just SlicerCaches("NativeTimeline_Date") refers to internal numbering of Time Lines, no names of them.
Related
I have a particular problem and couldn't find any solution anywhere on the internet.
So I have a pivot table which is connected to 6 slicers and also a chart which data range is dependent on pivot table values.
I've made a macro which updates chart scales everytime a value in any of the worksheet cells is changed. Here is the macro:
Public Sub worksheet_Change(ByVal Target2 As Range)
If ActiveSheet.Name = "Dashboard" Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DataEntryMode = xlOff
'Chart_axis Macro
Sheets("Dashboard").ChartObjects("Chart 9").Activate
If ActiveSheet.Range("B19") = "excluding CE" Then
ActiveChart.Axes(xlValue).MinimumScale = Range("E3").Value
ActiveChart.Axes(xlValue).MaximumScale = Range("E4").Value
Else
ActiveChart.Axes(xlValue).MinimumScale = Range("A3").Value
ActiveChart.Axes(xlValue).MaximumScale = Range("A4").Value
End If
ActiveChart.Refresh
ActiveSheet.Range("B18").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
In order to work as intended i also had to made a function which reads the active elements of a slicer:
Public Function GetSelectedSlicerItems(SlicerName As String) As String
Application.Volatile
Set coll = New Collection
Dim cache As Excel.SlicerCache
Dim i As Integer
Set cache = ActiveWorkbook.SlicerCaches(SlicerName)
Dim sItem As Excel.SlicerItem
Dim result As String
For Each sItem In cache.SlicerItems
If sItem.Selected And sItem.HasData Then
'Debug.Print sItem.Name
'Debug.Print sItem.HasData
'GetSelectedSlicerItems = (sItem.Name)
coll.Add sItem.Name
End If
Next sItem
For i = 1 To coll.Count
'Debug.Print coll(i)
result = result & coll(i) & ", "
Next i
result = Left(result, Len(result) - 2)
GetSelectedSlicerItems = result
End Function
My problem is that while the value of the function always updates when the slicer item is changed, the macro only does it randomly about 50% of the time.
Screenshot of my report:
The formulas containing the selected slicer items function are on the top right.
So do you have any idea how to make it work 100% of the time?
Thanks in advance,
Alan
Edit: i forgot to add that it's only the issue if only one slicer is highlited. When i select multiple slicers (with ctrl+click) it always works.
Hey I'm new to forums and this is my first post. I am new to vba in excel, but have written thinkscript in ThinkorSwim.
If anyone is familiar with a range stock chart, thats what Im going after.
I found code for a line chart, and am using it, but it is based on where price is at any given time. I want to modify this line chart to only plot values when they are above or below a range so that it resembles a candlestick chart with no wicks. Once data enters that range, I only want it to update whenever a new high or low is made in that range. The ranges need to be preset (ex. 50 ticks) Once the range is exceeded, I want the data plotted in the next range up, and repeat the process. Time and dates should be ignored, and only plot based on price action.
Does anyone have any ideas?
Option Explicit
'Update the values between the quotes here:
Private Const sChartWSName = "Chart"
Private Const sSourceWSName = "Sheet1"
Private Const sTableName = "tblValues"
Public RunTime As Double
Private Sub Chart_Setup()
'Create the structure needed to preserve and chart data
Dim wsChart As Worksheet
Dim lstObject As ListObject
Dim cht As Chart
Dim shp As Button
'Create sheet if necessary
Set wsChart = Worksheets.Add
wsChart.Name = sChartWSName
'Set up listobject to hold data
With wsChart
.Range("A1").Value = "Time"
.Range("B1").Value = "Value"
Set lstObject = .ListObjects.Add( _
SourceType:=xlSrcRange, _
Source:=.Range("A1:B1"), _
xllistobjecthasheaders:=xlYes)
lstObject.Name = sTableName
.Range("A2").NumberFormat = "h:mm:ss AM/PM (mmm-d)"
.Columns("A:A").ColumnWidth = 25
.Select
End With
'Create the chart
With ActiveSheet
.Shapes.AddChart.Select
Set cht = ActiveChart
With cht
.ChartType = xlLine
.SetSourceData Source:=Range(sTableName)
.PlotBy = xlColumns
.Legend.Delete
.Axes(xlCategory).CategoryType = xlCategoryScale
With .SeriesCollection(1).Format.Range
.Visible = msoTrue
.Weight = 1.25
End With
End With
End With
'Add buttons to start/stop the routine
Set shp = ActiveSheet.Buttons.Add(242.25, 0, 83.75, 33.75)
With shp
.OnAction = "Chart_Initialize"
.Characters.Text = "Restart Plotting"
End With
Set shp = ActiveSheet.Buttons.Add(326.25, 0, 83.75, 33.75)
With shp
.OnAction = "Chart_Stop"
.Characters.Text = "Stop Plotting"
End With
End Sub
Public Sub Chart_Initialize()
'Initialize the routine
Dim wsTarget As Worksheet
Dim lstObject As ListObject
'Make sure worksheet exists
On Error Resume Next
Set wsTarget = Worksheets(sChartWSName)
If Err.Number <> 0 Then
Call Chart_Setup
Set wsTarget = Worksheets(sChartWSName)
End If
On Error GoTo 0
'Check if chart data exists
With Worksheets(sChartWSName)
Set lstObject = .ListObjects(sTableName)
If lstObject.ListRows.Count > 0 Then
Select Case MsgBox("You already have data. Do you want to clear it and start fresh?", vbYesNoCancel, "Clear out old data?")
Case Is = vbYes
'User wants to clear the data
lstObject.DataBodyRange.Delete
Case Is = vbCancel
'User cancelled so exit routine
Exit Sub
Case Is = vbNo
'User just wants to append to existing table
End Select
End If
'Begin appending
Call Chart_AppendData
End With
End Sub
Private Sub Chart_AppendData()
'Append data to the chart table
Dim lstObject As ListObject
Dim lRow As Long
With Worksheets(sChartWSName)
Set lstObject = .ListObjects(sTableName)
If lstObject.ListRows.Count = 0 Then
lRow = .Range("A1").End(xlDown).Row
End If
If lRow = 0 Then
lRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
End If
If lRow > 2 Then
If .Range("B" & lRow - 1).Value = Worksheets(sSourceWSName).Range("C10").Value Then
'Data is a match, so do nothing
Else
'Data needs appending
.Range("A" & lRow).Value = CDate(Now)
.Range("B" & lRow).Value = Worksheets(sSourceWSName).Range("C10").Value
End If
Else
'Data needs appending
.Range("A" & lRow).Value = CDate(Now)
.Range("B" & lRow).Value = Worksheets(sSourceWSName).Range("C10").Value
End If
End With
RunTime = Now + TimeValue("00:00:01")
Application.OnTime RunTime, "Chart_AppendData"
End Sub
Public Sub Chart_Stop()
'Stop capturing data
On Error Resume Next
Application.OnTime EarliestTime:=RunTime, Procedure:="Chart_AppendData", Schedule:=False
End Sub
Take your sheet of data and filter... example would be:
Columns("A:C").Sort key1:=Range("C2"), _
order1:=xlAscending, header:=xlYes
Sort info: https://msdn.microsoft.com/en-us/library/office/ff840646.aspx
You then can define to select your desired range. Assuming column A is x-axis and B is y-axis (where your parameters for modifying need to be assessed):
Dim High1 as integer
Dim Low1 as integer
High1 = Match(Max(B:B),B:B) 'This isn't tested, just an idea
Low1 = Match(Max(B:B)+50,B:B) 'Again, not tested
and using those defined parameters:
.Range(Cells(High1,1),Cells(Low1,2).Select
This should give an idea for High1/Low1, where you can work through how you want to define the row that the max value occurs.
You then CreateObject for the Chart you want, having selected the data range you are going to use.
I have an activeX dropdown form on my spreadsheet which executes code on _Change. My code modifies the dropdowns list source (adding or deleting items). Whenever this happens, the _Change is called again.
I have various workarounds, all of which were some version of changing the list source, but with no success. The reason none of this has worked is because clearing or altering the .ListFillRange actually triggers the _Change event again.
How do I prevent the _Changeevent from getting called if I want to add or delete items in the .ListFillRange
UPDATE w EnableEvents set to false:
Public Sub SetRangeForDropdown()
On Error Resume Next
Application.EnableEvents = False
'Get new List of employees from Employee sheet
Dim rng1 As Range
With wsDB_employee
Set rng1 = .Range("A2:B" & .Range("A10000").End(xlUp).Row)
End With
With wsStage
.Cells.Clear
rng1.Copy .Range(.Cells(1, 1), .Cells(rng1.Rows.Count, 2))
End With
'Set range for dropdown on employee sheet
Dim rng2 As Range
Set rng2 = wsStage.Range("A1:B" & wsStage.Range("A10000").End(xlUp).Row)
'Update employee list named formula
ActiveWorkbook.Names.Add Name:="nfEmployeeList", RefersTo:=rng2
Dim str As String
str = rng2.Parent.Name & "!" & rng2.Address 'Source path for list fill range
wsMA.cmbEmployeeSelection.ListFillRange = str
Application.EnableEvents = True
End Sub
Apperantly EnableEvents does not work for ActiveX controls.
Thank you Microsoft for making life just a little bit more complicated!
Just found this: "Application.EnableEvents=False/True ONLY applies to Sheet and Workbook Events, not ActiveX Control Events" from here enter link description here
You can disable the events in the SetRangeForDropdown and then enable them back.
So, write the following at the start:
Application.EnableEvents = False
And the following at the end:
Application.EnableEvents = true
it's always a good habit to make (nearly) sure that events handling is always brought back, like follows:
Public Sub SetRangeForDropdown()
'...your code
On Error GoTo ExitSub
Application.EnableEvents = False
wsMA.cmbEmployeeSelection.ListFillRange = rng2
'Update employee list named formula
ActiveWorkbook.Names.Add name:="nfEmployeeList", RefersTo:=rng2
ExitSub:
Application.EnableEvents = True
End Sub
Furthermore, avoid On Error Resume Next unless you really need it
I have solved the problem by adding a global variable that prevents the _Change event from firing. Here is that code:
Private Sub cmbEmployeeSelection_Change()
If bNOTRUN = False Then 'Check if ActiveX event should fire or not
modEmployeeDB.SaveEmployeeData 'Save currently selected employee data
modEmployeeDB.DBSoll_To_WorkerInfo 'Get called employee data
End If
End Sub
And this is the module as modified... note the simple Boolean variable that I added:
Public Sub SetRangeForDropdown()
On Error GoTo SetRangeForDropdown_Error
bNOTRUN = True 'Global Variable that when True prevents Active X from firing
'Get new List of employees from Employee sheet
Dim rng1 As Range
With wsDB_employee
Set rng1 = .Range("A2:B" & .Range("A10000").End(xlUp).Row)
End With
With wsStage
.Cells.Clear
rng1.Copy .Range(.Cells(1, 1), .Cells(rng1.Rows.Count, 2))
End With
'Set range for dropdown on employee sheet
Dim rng2 As Range
Set rng2 = wsStage.Range("A1:B" & wsStage.Range("A10000").End(xlUp).Row)
'Update employee list named formula
ActiveWorkbook.Names.Add Name:="nfEmployeeList", RefersTo:=rng2
Dim str As String
str = rng2.Parent.Name & "!" & rng2.Address 'Source path for list fill range
wsMA.cmbEmployeeSelection.ListFillRange = str
bNOTRUN = False
On Error GoTo 0
Exit Sub
SetRangeForDropdown_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure SetRangeForDropdown of Sub modEmployeeDB"
bNOTRUN = False
End Sub
Here is my code of two sub procedures, one function, two other sub procedures for macro protection (irrelevant). The last sub procedure, sub manual_date() is the center of my inquiry. How could I divert the macro code if the user of this macro choose to manually input their own date. The main code is highlighted as the center code screen. I know I could very easily copy and paste as a solution. I am interested in an advanced coding strategy.
Option Explicit
Sub Client_Dirty_Recon()
Dim Date_minus_one As Date ' Date & weekend logic
Dim answer As Long ' Date & weekend logic
Dim brow As Long ' Last filled cell in column
Dim yrow As Long ' Last filled cell in column
Dim nRow As Long ' Last filled cell in column
Dim c As Range ' rngWatch.Cells(i, 1).Value
Dim oldStatusBar As Variant ' Save StatusBar status
Dim Client_path As String ' Range("Path")
Dim wb As Workbook ' ThisWorkbook
Dim wbDirty As Workbook ' Workbooks.Open(Client_path)
Dim rngReconcile As Range ' wb.Sheets(1).Range("K:K")
Dim rngWatch As Range ' wbDirty.Sheets(1).Range("A:A")
Dim rngNew As Range ' wbNew.Sheets(1).Range("A:A")
Dim failed_count As Long
Dim FS
oldStatusBar = Application.DisplayStatusBar 'optional - save StatusBar
Application.DisplayStatusBar = True 'optional - turn on StatusBar
Application.ScreenUpdating = False 'optional - screen won't flash
Application.StatusBar = "Opening workbooks..." 'optional - Update user
Call Unprot
Date_minus_one = Date
answer = IsMonday(Date_minus_one)
If answer = True Then
Date_minus_one = Date - 3
Else
Date_minus_one = Date - 1
End If
Set FS = CreateObject("Scripting.FileSystemObject")
Set wb = ThisWorkbook
' Client_path = wb.Names("Path").RefersToRange.Value ' use path as defined name on sheet
Client_path = "XXXXXXX " & Format(Date_minus_one, "mmddyyyy") & ".xls"
If FS.fileexists(Client_path) Then
' Get only used part of column
Set rngReconcile = wb.Sheets(1).Range("K:K")
nRow = rngReconcile(rngReconcile.Cells.Count).End(xlUp).Row ' Get last filled cell
Set rngReconcile = Range(rngReconcile(1), rngReconcile(nRow)) ' Reduce rng size
Set wbDirty = Workbooks.Open(Client_path) ' Assumes it exists and is not open
' Get only used part of column
Set rngWatch = wbDirty.Sheets(1).Range("A:A")
nRow = rngWatch(rngWatch.Cells.Count).End(xlUp).Row ' Get last filled cell
Set rngWatch = Range(rngWatch(3), rngWatch(nRow)) ' Reduce range size
Set rngNew = wb.Sheets("Client Watchlist").Range("K:K")
brow = rngNew(rngNew.Cells.Count).End(xlUp).Row
Set rngNew = Range(rngNew(2), rngNew(brow))
rngNew.ClearContents
Set rngNew = wb.Sheets(1).Range("K:K")(rngNew.Cells.Count).End(xlUp)(2)
For Each c In rngWatch ' Each value in rngWatch
On Error Resume Next ' Interrupt Error checking
If IsError(WorksheetFunction.Match( _
c.Value, rngReconcile, 0)) Then ' If not in rngReconcile
rngNew.FormulaR1C1 = c.Value ' Copy to rngNew
Set rngNew = rngNew(2) ' Moves range down =Offset(rngNew,1,0)
End If
On Error GoTo 0 ' Reset Error checking
If (c.Row + 1) Mod 100 = 0 Then ' Optional - Update user
Application.StatusBar = "Evaluating cell " & c(2).Address & "..."
End If
Next c
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar ' Reset Status Bar
ActiveWindow.Close Savechanges:=False ' Closes client email
MsgBox ("Reconcilied to ") & Client_path & " on " & Now
Else
MsgBox ("Please save down ") & Client_path, vbCritical
End If
Call Prot
Application.ScreenUpdating = True ' Turn back on
End Sub
Public Function IsMonday(inputdate As Date) As Boolean
Select Case Weekday(inputdate)
Case vbMonday
IsMonday = True
Case Else
IsMonday = False
End Select
End Function
Sub manual_date()
manual_date_input = InputBox("Enter Date (MMDDYYYY")
End Sub
Update
I added the following two sub procedures which shall pass the dt parameter as instructed below. I feel as if this variable dt as date is storing a value? I am able to run the sub procedure Sub RunWithUserDate() but the Sub RunWithDefault() procedure does not run smoothly. I have inserted several message boxes to view the value of dt. Should I be resetting the value of this date variable? If so, how could I? (Please note, I have cleaned up the code within the main sub procedure Sub Client_Dirty_Recon() and I have properly assigned the dt variable within the client_path variable.
Sub test2()
MsgBox Date
MsgBox dt
MsgBox IsMonday(dt)
IsMonday (dt)
MsgBox (dt)
End Sub
Public Function IsMonday(inputdate As Date) As Boolean
Select Case Weekday(inputdate)
Case vbMonday
dt = Date - 3 ' IsMonday = True
'dt = Format(dt, "mmddyyyy")
Case Else
dt = Date - 1
'dt = Format(Date - 1, "mmddyyyy") ' IsMonday = False
'dt = Format(dt, "mmddyyyy")
End Select
End Function
Sub RunWithDefault() ' Button 1: use current date
'CHECK THIS AGAIN ***ALSO ADD PERMISSIONS IF NECESSARY
MsgBox IsMonday(dt)
MsgBox dt
Client_Dirty_Recon IsMonday(dt)
End Sub
' Button 2: get date from user
Sub RunWithUserDate() ' Get dt value from user
'PROMPT USER FOR PASSWORD
dt = Application.InputBox("Enter Date (MM/DD/YYYY)", "Manual Override")
'du = Format(du, "mmddyyyy")
'du = Format(Application.InputBox("Enter Date (MM/DD/YYYY)"), "mmddyyyy")
'dt = Format(dt, "mmddyyyy")
'MsgBox dt
Client_Dirty_Recon dt
'dt = Date
End Sub
Add a Date parameter to your main sub, and have (e.g.) two separate buttons, each linked to smaller "stubs" which in turn will call the main code. First one would pass the current date; second one would pass a date sourced from the user somehow.
'button 1: use current date
Sub RunWithDefault()
Client_Dirty_Recon Date
End Sub
'button 2: get date from user
Sub RunWithUserDate()
Dim dt As Date
'get dt value from user
Client_Dirty_Recon dt
End Sub
'main code
Sub Client_Dirty_Recon(dt as Date)
'run main processing
End Sub
I have a named range lstVendors that refers to: =OFFSET(Data!$W$2,0,0,COUNTA(Data!$W$2:$W$400),1). I want this range to be populated when the workbook opens. I have the following code for this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Range("lstVendors").Offset(0, 0).Value = "Please Select..."
' Set DropDown1 = ThisWorkbook.Sheets("Dashboard").DropDowns("Drop Down 1")
' DropDown1.Value = 1
On Error Resume Next
If Not IsError(Range("lstVendors")) Then
Range("lstVendors").ClearContents
End If
On Error GoTo 0
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
Set startRng = Range("lstVendors")
i = 0
For n = 2 To UBound(rslt)
Range("lstVendors").Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
It errors on the Set startRng = Range("lstVendors"). I know this is because there's nothing in the range when I'm trying to set it, because if I put one entry into the named range, the set works, however, I need it populated by the sqlite query on each open as the data changes.
Any suggestions much appreciated.
Try this. You have a dynamic range that doesn't evaluate after you clear the contents. To avoid this, there are probably several ways, but easy to simply hardcode the startRange variable so that it always points to Data!$W$2 address, which is (or rather, will become) the first cell in your lstVendors range.
Private Sub Workbook_Open()
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
Dim rngList As Range
'// Define your startRange -- always will be the first cell in your named range "lstVendors"
' hardcode the address because the dynamic range may not evalaute.
Set startRange = Sheets("Data").Range("W2")
'// Empty th lstVendors range if it exists/filled
On Error Resume Next
Range("lstVendors").Clear
On Error GoTo 0
'// Run your SQL query
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
i = 0
'// Print results to the Worksheet, beginning in the startRange cell
For n = 2 To UBound(rslt)
'Increment from the startRange cell
startRange.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
'Verify that "lstVendors" is being populated
Debug.Print Range("lstVendors").Address
Next n
End Sub
Thanks for the suggestions. Here is what I ended up doing in order to get around my problem. It involves adding something I didn't specify would be ok in my original question, so David's answer is great if what I did isn't an option. I first populated the first two cells in my named range with "Please Select..." and "All". In Sub Workbook_Open() we do this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
' Disable our not found message
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Set our start range to our named range
Set startRng = Range("lstVendors")
' Grab all vendor names
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
' Print result. Skip first two rows as constants "Please Select..." and "All" are populated there
i = 2
For n = 2 To UBound(rslt)
startRng.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
Then we will create Sub Workbook_BeforeClose:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' Disable the save changes dialog. This workbook will be locked up for display only. No need to confuse the user.
Application.DisplayAlerts = False
' Clear everything below the "Please Select..." and "All" cells in the named range
On Error Resume Next
Range("lstVendors").Offset(2, 0).ClearContents
On Error GoTo 0
' Save the changes to the named range
ThisWorkbook.Save
Application.DisplayAlerts = True
End Sub
This information is going to populate a drop down, so having Please Select and All hardcoded into the named range is acceptable for me. If that stipulation doesn't work for someone else looking at this in the future, please use David's suggestion! Thanks again!