Visual Basic For Applications“下标超出范围”错误

问题描述

" 在向数组中添加两个新元素后，出现下标超出范围错误。我删除了这些元素并重新运行代码，它可以工作。我需要知道在哪里更改范围以适应数组元素。这是编辑后的代码： products = Array("BALANCER","SKIN LIGHTENER","FIRM AND FADE 6%","FIRM AND FADE 8%") 添加两个附加元素后，将引发错误。 研究表明，数组是问题所在，但是在进行调整后，仍然会抛出错误消息。 "

“这是原始代码：”

    Public Sub Dermesse_Dashboard(SD As Date,ED As Date)

    Dim cn As ADODB.Connection
    Dim rs As ADODB.RecordSet
    Dim com As ADODB.Command
    Dim ConnectionString As String,StoredProcName As String
    Dim StartDate As ADODB.Parameter,EndDate As ADODB.Parameter,Product As ADODB.Parameter
    Dim excelrange As String
    Dim Daterange As String
    Dim RCount As Integer
    Dim products As Variant
    products = Array("BALANCER","SKIN LIGHTENER")
    
    Set cn = New ADODB.Connection
    Set rs = New ADODB.RecordSet
    Set com = New ADODB.Command
    
    Workbooks.Open ("\\apfssvr01\Arrow_RX\Reports\Templates\Dermesse_Dashboard(Template).xlsx")
        
    ConnectionString = "Provider=sqloledb;Data Source=ARWsql01;initial catalog=futurefill;User Id=endicia;Pwd=endicia;trusted_connection=yes;"
    
    On Error GoTo CloseConnection
    
    Application.ScreenUpdating = False
    
    cn.Open ConnectionString
    cn.CursorLocation = adUseClient

    StoredProcName = "Dermesse_Shipped_by_Product"

    With com
        .ActiveConnection = cn
        .CommandType = adCmdstoredProc
        .CommandText = StoredProcName
    End With
    
    Set StartDate = com.CreateParameter("@StartDate",adDBTimeStamp,adParamInput,SD)
    com.Parameters.Append StartDate

    Set EndDate = com.CreateParameter("@Enddate",ED)
    com.Parameters.Append EndDate
        
    ActiveWorkbook.Sheets(2).Select
    

    'loop through each item in products.
    For Each i In products
        'remove the product parameter if it exists so we can set it to the next product
        If Product Is nothing = False Then
            com.Parameters.Delete (2)
        End If
        
        Set Product = com.CreateParameter("@Product",adVarChar,200,i)
        com.Parameters.Append Product
    
        Set rs = com.Execute
        
        'add rows to the excel table if the record set if 2 or greater.
        'if we dont any tables below the first Could be over written
        If rs.RecordCount >= 2 Then
            For j = 0 To rs.RecordCount - 3
                ActiveSheet.ListObjects("Ship " & i).ListRows.Add (2)
            Next
        End If
        
        ActiveSheet.ListObjects("Ship " & i).DataBodyRange.Select
        Selection.copyFromrecordset rs

        rs.Close
    Next
    
        ActiveWorkbook.Sheets(6).Select
    
        StoredProcName = "Dermesse_Shipped_wOrder"
        
        With com
            .ActiveConnection = cn
            .CommandType = adCmdstoredProc
            .CommandText = StoredProcName
        End With
        
        If Product Is nothing = False Then
            com.Parameters.Delete (2)
        End If
        
        Set Product = com.CreateParameter("@Product","Dermesse")
        com.Parameters.Append Product
    
        Set rs = com.Execute
        RCount = rs.RecordCount
        
        With ActiveSheet.ListObjects("Invoice DERMESSE")
            If rs.RecordCount >= 2 Then
                For j = 0 To rs.RecordCount - 3
                    .ListRows.Add (2)
                Next
            End If
            
            .DataBodyRange.Select
            
            Selection.copyFromrecordset rs
            
            .ListColumns(12).Range.Select
            Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
        End With
        
        rs.Close
  
    cn.Close
        'set a data fee value for each record.  look at the order number of a specific line.  if the line above or below are the same
        'the data fee is 7.5 else is 10
        r = 9
        For i = 0 To RCount - 1
            If ActiveSheet.Range("C" & r + i).Value = ActiveSheet.Range("C" & (r + i) - 1).Value Then
                ActiveSheet.Cells(r + i,12).Value = 7.5
            ElseIf ActiveSheet.Range("C" & r + i).Value = ActiveSheet.Range("C" & (r + i) + 1).Value Then
                ActiveSheet.Cells(r + i,12).Value = 7.5
            Else
                ActiveSheet.Cells(r + i,12).Value = 10
            End If
        Next i
    
    If SD <> ED Then
        Daterange = Format(SD,"yyyy-mm-dd") & " through " & Format(ED,"yyyy-mm-dd")
    Else
        Daterange = Format(SD,"yyyy-mm-dd")
    End If
    
    With ActiveWorkbook
        For i = 1 To .Sheets.Count
            .Sheets(i).Select
            .Sheets(i).Range("A2").Value = Daterange
        Next
        .Sheets("Dermesse Dashboard").Select
    End With
    
    On Error GoTo 0
    Application.displayAlerts = False
    ActiveWorkbook.RefreshAll
    Application.displayAlerts = False
    ActiveWorkbook.SaveAs ("\\apfssvr01\Arrow_RX\Reports\Dermesse\DERMESSE_Dashboard(" & Daterange & ").xlsx"),FileFormat:=51
    Application.displayAlerts = True
    ActiveWorkbook.Close
    Application.displayAlerts = True
    Application.ScreenUpdating = True
    frmSwitchboard.lblDD.Caption = "Report Complete"
    Exit Sub
    
CloseConnection:
    Application.ScreenUpdating = True
    frmSwitchboard.lblDD.Caption = "Error: " & Error
    cn.Close
    If ActiveWorkbook.Sheets(1).Name <> "Sheet1" Then
        Application.displayAlerts = False
        ActiveWorkbook.Close
        Application.displayAlerts = True
    End If

End Sub

任何帮助将不胜感激

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）