在列表对象上获取超出范围的下标

时间:2016-08-01 15:06:49

标签: excel vba excel-vba

所以,我一直在研究一个允许通过excel编辑数据库表的代码,而且我遇到了一个表对象。

代码在其他工作表上的编写方式几乎完全相同,但由于某些原因,只有这个工作表在设置列表对象时才会给出下标超出范围错误。我检查了桌子的名称,并尝试更换它几次。我错过了什么?

到目前为止,这是代码:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim CustomersConn As ADODB.Connection
    Dim CustomersCmd As ADODB.Command
    Dim lo As Excel.ListObject
    Dim ws As Excel.Worksheet
    Dim lrs As Range
    Dim lr As Excel.ListRow
    Dim Customers As Variant
    Dim areaCount As Integer
    Dim i As Integer
    Dim Rows As Range
    Dim rRow As Range
    Dim lRows As Excel.ListRows
    Dim Counter As Double

    Set ws = ThisWorkbook.Worksheets(11)
    Set lo = ws.ListObjects("TProspects")
    Set CustomersConn = New ADODB.Connection
    Set CustomersCmd = New ADODB.Command
    Set lrs = Target

    For Each Rows In lrs.Rows
        On Error GoTo jmp

        '========Section 1===========
        If Counter < 1 Then
            Intersect(lr.Range, lo.ListColumns("ID").Range).Value = WorksheetFunction.Max(lo.ListColumns("ID").Range) + 1
        End If
        '^^^^^^^^Section 1^^^^^^^^^^^

        Set lr = lo.ListRows(Rows.Row - 5)


        CustomersConn.ConnectionString = SQLConStr
        CustomersConn.Open
        CustomersCmd.ActiveConnection = CustomersConn

        CustomersCmd.CommandText = _
            GetUpdateText( _
            Intersect(lr.Range, lo.ListColumns("ID").Range).Value, _
            Intersect(lr.Range, lo.ListColumns("Prospect").Range).Value, _
            Intersect(lr.Range, lo.ListColumns("Contact").Range).Value, _
            Intersect(lr.Range, lo.ListColumns("Email").Range).Value, _
            Intersect(lr.Range, lo.ListColumns("Phone").Range).Value, _
            Intersect(lr.Range, lo.ListColumns("Address").Range).Value, _
            Intersect(lr.Range, lo.ListColumns("City").Range).Value, _
            Intersect(lr.Range, lo.ListColumns("State").Range).Value, _
            Intersect(lr.Range, lo.ListColumns("Zip").Range).Value, _
            Intersect(lr.Range, lo.ListColumns("Buying Group").Range).Value, _
            Intersect(lr.Range, lo.ListColumns("Type").Range).Value)

        CustomersCmd.Execute

    Next Rows

    CustomersConn.Close

    Set CustomersConn = Nothing
    Set lo = Nothing
    Set ws = Nothing
    Set lr = Nothing

    Application.Calculation = xlCalculationAutomatic

jmp:
End Sub

GetUpdateText 功能:

Function GetUpdateText(ID As Double, Prospect As String, Contact As String, Email As String, Phone As String, Address As String, City As String, State As String, Zip As Double, Corp As String, CType As String) As String

    Dim SQLStr As String

    SQLStr = _
        "UPDATE Prospect" & _
        " SET Type = '" & CType & "'," & _
        "Prospect = '" & Replace(Prospect, "'", "''") & "'," & _
        "Contact = '" & Contact & "'," & _
        "Email = '" & Email & "'," & _
        "Phone = '" & Phone & "'," & _
        "Address = '" & Address & "'," & _
        "City = '" & City & "'," & _
        "State = '" & State & "'," & _
        "Zip = " & Zip & "," & _
        "[Buying Group] = '" & Corp & "'" & _
        "WHERE ID = " & ID & _
        "IF @@ROWCOUNT=0" & _
        "INSERT INTO Prospect (" & _
        "Type,Contact,Prospect,Email,Phone,Address,City,State,Zip,[Buying Group])" & _
        "VALUES (" & _
        "'" & CType & "'," & _
        "'" & Contact & "'," & _
        "'" & Replace(Prospect, "'", "''") & "'," & _
        "'" & Email & "'," & _
        "'" & Phone & "'," & _
        "'" & Address & "'," & _
        "'" & City & "'," & _
        "'" & State & "'," & "'" & Zip & "'," & "'" & Corp & "')"

    GetUpdateText = SQLStr

End Function

1 个答案:

答案 0 :(得分:0)

Matt Cremeens和Andrew Wynn提出了一个有效的观点,指导我到达我需要的地方。

虽然我确实在表索引11上有表,但出于任何原因,利用表单的名称而不是索引值工作。我完全忘记了Worksheets是一个关联数组。至于为什么指数不起作用,这完全是个谜。