Subscript out of range error in query table code

[dhouseknecht]

Hi All,

I've scavenged some code from a forum and I'm getting a subscript out of range error and I'm not sure what's going on. I'm really pretty new to VBA so go easy on me please. Also, sorry for the code snippets not being up to snuff in terms of formatting...I couldn't get the MrExcel add in working. Any help is greatly appreciated!!! Thanks in advance

When opening the spreadsheet, it throws a Error 9: Subscript out of range. And if I step through the code, it errors in MonitorQuery.

The code was found here:http://www.mrexcel.com/forum/excel-questions/670259-query-excel-updating-keeping-new-data.html

Code in ThisWorkbook

Private Sub Workbook_Open()​

'--Start monitoring for connection refresh events​

Call Sheets("Data").MonitorQuery​

End Sub​

Initial subset of Code in Sheet 1

Option Explicit​

​

Private WithEvents qt As QueryTable​

Private vStoredNotes As Variant, vKeysBefore As Variant​

Private sTableName As String, sKeyField As String​

Private sFirstNoteField As String, sLastNoteField As String​

​

Public Sub MonitorQuery()​

'--initialize module scope variables​

sTableName = "Data"​

sKeyField = "OBJECTID"​

sFirstNoteField = "STATUS"​

sLastNoteField = "COMMENTS"​

​

On Error GoTo ErrorHandler​

Set qt = Me.ListObjects(sTableName).QueryTable​

Exit Sub​

ErrorHandler:​

MsgBox "Error " & Err & ": " & Error(Err.Number)​

End Sub​

 

[RoryA]

It sounds like you don't have a table called "Data"

 

[dhouseknecht]

If you follow the link, the poster says "6. Paste this code into the Sheet Code Module and edit "MyQTable" in the code to match your Query Table's name." and the original code was as follows:

I tried using "Data" which is my sheet name along with a bunch of other things. How do I find out what my Query Table Name is?


Public Sub MonitorQuery() '--initialize module scope variables sTableName = "MyQTable" sKeyField = "FAZ_ID" sFirstNoteField = "namireno" sLastNoteField = "isporuceno dana" On Error GoTo ErrorHandler Set qt = Me.ListObjects(sTableName).QueryTable Exit SubErrorHandler: MsgBox "Error " & Err & ": " & Error(Err.Number)End Sub</pre>

 

[RoryA]

Click somewhere in the table, then check its name on the Table tab on the right side of the Ribbon

 

[dhouseknecht]

Hi RoryA,

I'm running 2003 but when I right click on the data range of the query and go to External Data Range Properties, it lists the name as "Query from LMS_PROD". However, if I try to define sTableName = "Query from LMS_PROD", I still get the Subscript out of range error. I've tried sTableName = "Data" which is the worksheet name. I've tried sTableName = "V_All_In_One" which is the actual table in SQL server that it is querying from. I guess I'm not sure what they are looking for in the code listed in the link. I did find a thread somewhere about someone listing the a query name as [something].[somethingelse]...is this the format the code is looking for?

I really do appreciate all the help! Thanks,

 

[RoryA]

If you're running 2003 the chances are it's not a listobject at all. Try using

set qt = me.querytables(1)

 

[dhouseknecht]

Agh...Victory was short lived. You got me past my subscript out of range error to discover a Error 1004: Method 'Range' of object '_Worksheet' failed....any thoughts? I wish I knew VBA better. I don't need it all that often in my job but when I do, it's a bear to get through :-/

 

[RoryA]

None of your code mentions Range anywhere...

 

[dhouseknecht]

Here's all the code on Sheet 1...I'm at your mercy

The commented block a the bottom is my formatting code which currently runs on cell change but I'll also end up having to make it re-run after the query table refresh. Basically I was hoping for a quick win to get my coworker to stop updating colors and formatting manually...it's not turning out to be such a quick win.

Any help is greatly appreciated!!!

Option Explicit

Private WithEvents qt As QueryTable
Private vStoredNotes As Variant, vKeysBefore As Variant
Private sTableName As String, sKeyField As String
Private sFirstNoteField As String, sLastNoteField As String


Public Sub MonitorQuery()
    '--initialize module scope variables
    sTableName = "Data"
    sKeyField = "OBJECTID"
    sFirstNoteField = "KEVINSTATUS"
    sLastNoteField = "COMMENTS"
    
    On Error GoTo ErrorHandler
    Set qt = Me.QueryTables(1)
    Exit Sub
ErrorHandler:
    MsgBox "Error " & Err & ": " & Error(Err.Number)
End Sub


Private Sub qt_BeforeRefresh(Cancel As Boolean)
    On Error GoTo ErrorHandler
    '--store the unique IDs from the QueryTable
    vKeysBefore = Application.Transpose(Me.Range(sTableName & "[" & sKeyField & "]"))
    '--store the Notes data
    With Me.Range(sTableName & "[[" & sFirstNoteField & "]:[" & sLastNoteField & "]]")
        vStoredNotes = Application.Transpose(.Cells)
        .Cells.ClearContents
    End With
    Exit Sub
ErrorHandler:
    vStoredNotes = Empty
    MsgBox "Error " & Err & ": " & Error(Err.Number)
End Sub


Private Sub qt_AfterRefresh(ByVal Success As Boolean)
    Dim vKeysAfter As Variant, vRemapped As Variant
        
    If IsEmpty(vStoredNotes) Then Exit Sub
    
    On Error GoTo ErrorHandler
    If Success Then
        '--Get updated unique IDs from the QueryTable
        vKeysAfter = Application.Transpose(Me.Range(sTableName & "[" & sKeyField & "]"))
        '--Transfer stored data into new array matching new order of Unique IDs
        vRemapped = Remap_Notes(vStoredNotes, vKeysBefore, vKeysAfter)
    Else
        vRemapped = vStoredNotes
    End If
    '--Write remapped data
    Me.Range(sTableName & "[[" & sFirstNoteField & "]:[" & sLastNoteField & "]]") _
        .Resize(UBound(vStoredNotes, 2), UBound(vStoredNotes)) _
            = Application.Transpose(vRemapped)


    Exit Sub
ErrorHandler:
    MsgBox "Error " & Err & ": " & Error(Err.Number)
End Sub


Private Function Remap_Notes(vStored, vKeysBefore, vKeysAfter) As Variant
    Dim vRemapped As Variant, vIdx As Variant
    Dim iRow As Long, iField As Long, iNoteFieldCount As Long
    
    On Error GoTo ErrorHandler
    
    '--resize array
    iNoteFieldCount = UBound(vStored, 1)
    ReDim vRemapped(1 To iNoteFieldCount, 1 To UBound(vKeysAfter))
    
    For iRow = 1 To UBound(vKeysAfter)
        vIdx = Application.Match(vKeysAfter(iRow), vKeysBefore, 0)
        '--if match, transfer row of stored data
        If Not IsError(vIdx) Then
            For iField = 1 To iNoteFieldCount
                vRemapped(iField, iRow) = vStored(iField, vIdx)
            Next iField
        End If
    Next iRow
    Remap_Notes = vRemapped
    Exit Function
ErrorHandler:
    MsgBox "Error " & Err & ": " & Error(Err.Number) & vbCr _
        & "Notes will be restored to previous range"
    Remap_Notes = vStored
End Function
'Private Sub Worksheet_Change(ByVal Target As Range)
'
''   Trigger when a single cell in column C is updated
'    If (Target.Count = 1) And (Target.Column = Range("C1").Column) Then
''   Check to see if column C is blank
'        If Cells(Target.Row, "C") = "" Then
''   Enter formula in column C
'            Application.EnableEvents = False
'            Cells(Target.Row, "C").FormulaR1C1 = "=IF(AND(RC[17]=""-1"",RC[16]=1),""Needs FPA GIS done"",IF(AND(RC[17]=""-1"",RC[16]=-1),""Needs FPA GIS not done"",IF(AND(RC[11]<>1,OR(RC[15]=0.25,RC[15]=0.5,RC[15]=0.75)),""Field Engineering/ GEO not done"","""")))"
'            Application.EnableEvents = True
'        End If
'        If Cells(Target.Row, "C") <> Cells(Target.Row, "AC") Then
'        Cells(Target.Row, "C").Font.FontStyle = "Bold"
'        Else: Cells(Target.Row, "C").Font.FontStyle = "Regular"
'        End If
'    End If
'Set MyPlage = Range("C2:C2500")
'    For Each Cell In MyPlage
'
'        If Cell.Value = "Needs FPA GIS done" Then
'            Cell.EntireRow.Interior.ColorIndex = 6
'        ElseIf Cell.Value = "Needs FPA GIS not done" Then
'            Cell.EntireRow.Interior.ColorIndex = 23
'        ElseIf Cell.Value = "Field Engineering/ GEO not done" Then
'            Cell.EntireRow.Interior.ColorIndex = 39
'        ElseIf Cell.Value = "FPA drafted" Then
'            Cell.EntireRow.Interior.ColorIndex = 10
'        ElseIf Cell.Value = "FPA mailed" Then
'            Cell.EntireRow.Interior.ColorIndex = 22
'        Else: Cell.EntireRow.Interior.ColorIndex = xlNone
'        End If
'
'    Next
'
'End Sub
'Private Sub QueryTable_AfterRefresh(Success As Boolean)
'    If (Success) Then Application.Run "Worksheet_Change"
'    End If
'End Sub

 

[dhouseknecht]

bump