Warum erzeugt diese Schleife einen Überlauf?

Question

Ich erstelle einige Prozeduren, um basierend auf Daten und Benutzereingaben einen Bericht zu generieren. Der Code kopiert die erforderlichen Informationen für den Basisbericht, und dann habe ich ein zusätzliches Blatt mit Zeitreihendaten, die ich nach dem ersten Kopieren in den Bericht einfügen möchte.

Dieser Abschnitt des Codes wird ein Überlauf nach wenigen Iterationen durch die Herstellung von:

For Each rpt_jobtitle In ws.Range("B2:B" & ws.Cells(ws.Rows.Count, 2).End(xlUp).row) 
    For Each rw In col_tsJobs 
     If rpt_jobtitle.Value = ts_ws.Cells(rw, 2).Value Then 
      If rpt_jobtitle.Offset(0, 1).Value = ts_ws.Cells(rw, 3).Value Then 
       If rpt_jobtitle.Offset(0, 2).Value = ts_ws.Cells(rw, 4).Value Then 
        ws.Cells(rpt_jobtitle.row, 13).Value = dict_TSViews.Item(rw) 
        ws.Cells(rpt_jobtitle.row, 14).Value = dict_TSApplicants.Item(rw) 
        ws.Cells(rpt_jobtitle.row, 15).Value = (dict_TSApplicants.Item(rw)/dict_TSViews.Item(rw)) 
        ws.Cells(rpt_jobtitle.row, 16).Value = (dict_TSApplicants.Item(rw)/(this.ToDate - this.FromDate)) 
        Exit For 
       End If 
      End If 
     End If 
    Next rw 
Next rpt_jobtitle 

Für Zusammenhang ist es innerhalb dieser Klasse Modul enthalten ist, - ist die Schleife innerhalb des InsertTSData() Subroutine am Boden:

Option Explicit 

Private Type Reports 
    RequisitionNumber As String 
    FromDate As Date 
    ToDate As Date 
    JobTitle As String 
    JobLocation As String 
    JobCategory As String 
    RecruiterName As String 
    TSViews As Long 
    TSApplicants As Long 
End Type 
Private this As Reports 
Public Property Let RequisitionNumber(ByVal inputValue As String) 
    this.RequisitionNumber = inputValue 
End Property 
Public Property Get RequisitionNumber() As String 
    RequisitionNumber = this.RequisitionNumber 
End Property 

Public Property Let JobTitle(ByVal inputValue As String) 
    this.JobTitle = inputValue 
End Property 
Public Property Get JobTitle() As String 
    JobTitle = this.JobTitle 
End Property 
Public Property Let JobLocation(ByVal inputValue As String) 
    this.JobLocation = inputValue 
End Property 
Public Property Get JobLocation() As String 
    JobLocation = this.JobLocation 
End Property 
Public Property Let JobCategory(ByVal inputValue As String) 
    this.JobCategory = inputValue 
End Property 
Public Property Get JobCategory() As String 
    JobCategory = this.JobCategory 
End Property 
Public Property Let RecruiterName(ByVal inputValue As String) 
    this.RecruiterName = inputValue 
End Property 
Public Property Get RecruiterName() As String 
    RecruiterName = this.RecruiterName 
End Property 
Public Property Get TSViews() As Long 
    TSViews = this.TSViews 
End Property 
Public Property Get TSApplicants() As Long 
    TSApplicants = this.TSApplicants 
End Property 
Public Property Get FromDate() As String 
    FromDate = this.FromDate 
End Property 
Public Property Let FromDate(ByVal inputValue As String) 
    this.FromDate = inputValue 
End Property 
Public Property Get ToDate() As String 
    ToDate = this.ToDate 
End Property 
Public Property Let ToDate(ByVal inputValue As String) 
    this.ToDate = inputValue 
End Property 


Private Function DateRange() As Variant 
    Dim postcell As Range 
    Dim pausecell As Range 
    Dim unpausecell As Range 
    Dim closecell As Range 
    Dim arr_validRows() As Variant 
    Dim ws As Worksheet 

    Set ws = Sheets(1) 

    ReDim arr_validRows(0) As Variant 
    Dim z As Range 
    For Each z In ws.Range("D3:D" & ws.Cells(ws.Rows.Count, 2).End(xlUp).row) 
     Set postcell = z 
     Set pausecell = z.Offset(0, 1) 
     Set unpausecell = z.Offset(0, 2) 
     Set closecell = z.Offset(0, 3) 

     If Not closecell.Value = "?" Then 
      If CDate(postcell.Value) <= this.ToDate Then 
       If Not pausecell.Value = "" Then 
        If CDate(pausecell.Value) >= this.FromDate Then 

         ReDim Preserve arr_validRows(UBound(arr_validRows) + 1) As Variant 
         arr_validRows(UBound(arr_validRows)) = z.row 

        ElseIf CDate(pausecell.Value) < this.FromDate And CDate(unpausecell.Value) >= this.FromDate Then 

         ReDim Preserve arr_validRows(UBound(arr_validRows) + 1) As Variant 
         arr_validRows(UBound(arr_validRows)) = z.row 

        End If 
       Else 
        If CDate(closecell.Value) >= this.FromDate Then 

         ReDim Preserve arr_validRows(UBound(arr_validRows) + 1) As Variant 
         arr_validRows(UBound(arr_validRows)) = z.row 

        End If 
       End If 
      End If 
     End If 
    Next z 

    DateRange = arr_validRows 
End Function 

Sub AddToReport(ByVal sheetname As String) 
    Dim ws As Worksheet 
    Dim newrow As Long 
    Set ws = Worksheets("Metric") 

    Dim exists As Boolean 
    exists = False 

    Dim i As Integer 
    For i = 1 To Worksheets.Count 
     If Worksheets(i).Name = sheetname Then 
      exists = True 
     End If 
    Next i 

    If Not exists Then 
     Call CreateSheet(sheetname) 

     With ThisWorkbook.Worksheets(sheetname) 
      .Range("1:1").Value = ws.Range("1:1").Value 
     End With 
    End If 


    Dim array_rows() As Variant 
    array_rows = DateRange() 

    Dim z As Variant 
    Dim w As Integer 

    With ThisWorkbook.Worksheets(sheetname) 
     newrow = .Cells(.Rows.Count, 2).End(xlUp).row 

     For z = 1 To UBound(array_rows) 
      newrow = newrow + 1 

      .Range(newrow & ":" & newrow).Value = ws.Range(array_rows(z) & ":" & array_rows(z)).Value 
     Next z 
    End With 
End Sub 

Sub TimeSeriesSummation(ByVal sheetname As String) 
    Dim ts_wkst As Worksheet 
    Dim rpt_wkst As Worksheet 
    Dim dateRow As Range 
    Dim jobTitleColumn As Range 
    Dim validDates As Collection 
    Dim validJobs As Collection 
    Dim reportJobTitleColumn As Range 
    Dim lastColumn As Variant 


    Set rpt_wkst = ThisWorkbook.Worksheets(sheetname) 
    Set ts_wkst = ThisWorkbook.Worksheets("Time Series Data") 

    lastColumn = ts_wkst.Cells(1, ts_wkst.Columns.Count).End(xlToLeft).Address(RowAbsolute:=False, ColumnAbsolute:=False) 

    Set dateRow = ts_wkst.Range("A1:" & lastColumn) 
    Set jobTitleColumn = ts_wkst.Range("B3:B" & ts_wkst.Cells(ts_wkst.Rows.Count, 2).End(xlUp).row) 
    Set reportJobTitleColumn = rpt_wkst.Range("B3:B" & rpt_wkst.Cells(rpt_wkst.Rows.Count, 2).End(xlUp).row) 

    Dim cellDate As Range 
    Dim potValidDate As Date 
    Set validDates = New Collection 

    For Each cellDate In dateRow 
     Debug.Print cellDate.Address 
     Debug.Print cellDate.Text 
     If Not cellDate.Text = "" Then 
      Debug.Print cellDate.Address 
      Debug.Print cellDate.Text 
      potValidDate = CDate(cellDate.Text) 
      If potValidDate <= this.ToDate Then 
       If potValidDate >= this.FromDate Then 
        'Add to an array/collection of stuff 
        validDates.Add cellDate.column 
        Debug.Print validDates.Item(validDates.Count) 
       End If 
      End If 
     End If 
    Next cellDate 

    Dim reportJobTitle As Range 
    Dim cellJobTitle As Range 
    Set validJobs = New Collection 

    For Each reportJobTitle In reportJobTitleColumn 
     For Each cellJobTitle In jobTitleColumn 
      If Not cellJobTitle.Value = "" Then 
       If cellJobTitle.Value = reportJobTitle.Value Then 
        If cellJobTitle.Offset(0, 1).Value = reportJobTitle.Offset(0, 1).Value Then 
         If cellJobTitle.Offset(0, 2).Value = reportJobTitle.Offset(0, 2).Value Then 
          'valid row 
          validJobs.Add cellJobTitle.row 
          Debug.Print validJobs.Item(validJobs.Count) 
          Exit For 
         End If 
        End If 
       End If 
      End If 
     Next cellJobTitle 
    Next reportJobTitle 


    Dim rw As Variant 
    Dim col As Variant 
    Dim rangeViews As Scripting.Dictionary 
    Dim rangeApps As Scripting.Dictionary 
    Dim tempTotalViews As Long 
    Dim tempTotalApps As Long 

    Set rangeViews = New Scripting.Dictionary 
    Set rangeApps = New Scripting.Dictionary 

    tempTotalViews = 0 
    tempTotalApps = 0 
    For Each rw In validJobs 
     Debug.Print ts_wkst.Cells(rw, 2).Value & ":" 

     For Each col In validDates 

      tempTotalViews = tempTotalViews + ts_wkst.Cells(rw, col).Value 

      Debug.Print "Running Total (V):" & tempTotalViews 

      tempTotalApps = tempTotalApps + ts_wkst.Cells(rw, col + 1).Value 

      Debug.Print "Running Total (A):" & tempTotalApps 
     Next col 

     rangeViews.Add rw, tempTotalViews 
     rangeApps.Add rw, tempTotalApps 
     tempTotalViews = 0 
     tempTotalApps = 0 
    Next rw 

    For Each rw In validJobs 
     Debug.Print "Views:" & rangeViews.Item(rw) 
     Debug.Print "Apps:" & rangeApps.Item(rw) 
    Next rw 

    Call InsertTSData(sheetname, validJobs, rangeViews, rangeApps) 

    rangeViews.RemoveAll 
    rangeApps.RemoveAll 



End Sub 

Sub AdvancedFilters(_ 
    ByVal reqnum_on As Boolean, _ 
    ByVal jobcategory_on As Boolean, _ 
    ByVal recruiter_on As Boolean, _ 
    ByVal jobtitle_on As Boolean, _ 
    ByVal joblocation_on As Boolean, _ 
    ByVal sheetname As String) 

    Dim ws As Worksheet 
    Set ws = ThisWorkbook.Worksheets(sheetname) 

    With ws.Range("A:O") 
     ws.AutoFilterMode = False 
     If reqnum_on Then 
      'field 1 
      .AutoFilter field:=1, Criteria1:="<>" & this.RequisitionNumber 
     End If 

     If jobcategory_on Then 
      'field 13 
      .AutoFilter field:=13, Criteria1:="<>" & this.JobCategory 
     End If 

     If recruiter_on Then 
      'field 14 
      .AutoFilter field:=14, Criteria1:="<>" & this.RecruiterName 
     End If 

     If jobtitle_on Then 
      'field 2 
      .AutoFilter field:=2, Criteria1:="<>" & this.JobTitle 
     End If 

     If joblocation_on Then 
      'field 3 
      .AutoFilter field:=3, Criteria1:="<>" & this.JobLocation 
     End If 
    End With 

    If reqnum_on Or jobcategory_on Or recruiter_on Or jobtitle_on Or joblocation_on Then 
     ws.Range("B2:B" & ws.Cells(ws.Rows.Count, 2).End(xlUp).row).SpecialCells(xlCellTypeVisible).EntireRow.Delete 
     ws.AutoFilterMode = False 
    End If 

End Sub 

Private Sub CreateSheet(ByVal sheetname As String) 
    Dim ws As Worksheet 
    Set ws = ThisWorkbook.Sheets.Add(After:= _ 
      ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) 
    ws.Name = sheetname 
End Sub 

Sub Statistics(ByVal sheetname As String) 
    With ThisWorkbook.Worksheets(sheetname) 
     .Range("Q3").Value = "Descriptive Statistics" 
     .Range("Q4").Value = "Mean" 
     .Range("Q5").Value = "Median" 
     .Range("Q6").Value = "Std. Dev." 
     .Range("Q7").Value = "Variance" 

     .Range("R3").Value = "Total Days Active" 
     .Range("S3").Value = "Views" 
     .Range("T3").Value = "Applications" 
     .Range("U3").Value = "Views-To-Applications" 
     .Range("V3").Value = "Applications per Day" 

     .Range("R4").Value = "=AVERAGE(H$2:H$" & .Cells(.Rows.Count, 2).End(xlUp).row & ")" 
     .Range("R5").Value = "=MEDIAN(H$2:H$" & .Cells(.Rows.Count, 2).End(xlUp).row & ")" 
     .Range("R6").Value = "=STDEVP(H$2:H$" & .Cells(.Rows.Count, 2).End(xlUp).row & ")" 
     .Range("R7").Value = "=VARP(H$2:H$" & .Cells(.Rows.Count, 2).End(xlUp).row & ")" 

     Dim sourceRange As Range 
     Dim fillRange As Range 
     Set sourceRange = .Range("R4:R7") 
     Set fillRange = .Range("R4:V7") 

     Call sourceRange.AutoFill(fillRange) 

     .Range("R4:R7").NumberFormat = "0.00" 
     .Range("S4:S7").NumberFormat = "0.00" 
     .Range("T4:T7").NumberFormat = "0.00" 
     .Range("U4:U7").NumberFormat = "0.00%" 
     .Range("V4:V7").NumberFormat = "0.00" 


    End With 
End Sub 

Sub FormatColumns(ByVal sheetname As String) 
    With ThisWorkbook.Worksheets(sheetname) 
     .Range("H:H").NumberFormat = "0.00" 
     .Range("I:I").NumberFormat = "0" 
     .Range("J:J").NumberFormat = "0" 
     .Range("K:K").NumberFormat = "0.00%" 
     .Range("L:L").NumberFormat = "0.00" 

     .Columns("Q:W").EntireColumn.AutoFit 
     .Columns("A:N").EntireColumn.AutoFit 
     .Columns("E:G").EntireColumn.Hidden = True 
    End With 
End Sub 

Sub InsertTSData(ByRef sheetname As String, _ 
    ByRef col_tsJobs As Collection, _ 
    ByRef dict_TSViews As Scripting.Dictionary, _ 
    ByRef dict_TSApplicants As Scripting.Dictionary) 

    'Add new columns 
    Dim ws As Worksheet 
    Dim ts_ws As Worksheet 
    Dim date_range As String 
    Dim rw As Variant 
    Dim rpt_jobtitle As Range 

    Set ts_ws = ThisWorkbook.Worksheets("Time Series Data") 
    Set ws = ThisWorkbook.Worksheets(sheetname) 
    date_range = Format(this.FromDate, "mmm d") & " to " & Format(this.ToDate, "mmm d") 

    With ws 
     .Range("M:P").EntireColumn.Insert 
     .Range("M1").Value = date_range & " Views" 'CI 13 
     .Range("N1").Value = date_range & " Applicants" 'CI 14 
     .Range("O1").Value = date_range & " Views-Apps Conversion" 'CI15 
     .Range("P1").Value = date_range & " Apps/Day" 'CI16 
    End With 

    For Each rpt_jobtitle In ws.Range("B2:B" & ws.Cells(ws.Rows.Count, 2).End(xlUp).row) 
     For Each rw In col_tsJobs 
      If rpt_jobtitle.Value = ts_ws.Cells(rw, 2).Value Then 
       If rpt_jobtitle.Offset(0, 1).Value = ts_ws.Cells(rw, 3).Value Then 
        If rpt_jobtitle.Offset(0, 2).Value = ts_ws.Cells(rw, 4).Value Then 
         ws.Cells(rpt_jobtitle.row, 13).Value = dict_TSViews.Item(rw) 
         ws.Cells(rpt_jobtitle.row, 14).Value = dict_TSApplicants.Item(rw) 
         ws.Cells(rpt_jobtitle.row, 15).Value = (dict_TSApplicants.Item(rw)/dict_TSViews.Item(rw)) 
         ws.Cells(rpt_jobtitle.row, 16).Value = (dict_TSApplicants.Item(rw)/(this.ToDate - this.FromDate)) 
         Exit For 
        End If 
       End If 
      End If 
     Next rw 
    Next rpt_jobtitle 

End Sub 

Answer 1

In diesen beiden Linien

ws.Cells(rpt_jobtitle.row, 15).Value = (dict_TSApplicants.Item(rw)/dict_TSViews.Item(rw)) 
ws.Cells(rpt_jobtitle.row, 16).Value = (dict_TSApplicants.Item(rw)/(this.ToDate - this.FromDate)) 

nach dict_TSApplicants.Item(rw) return 0, entweder dict_TSViews.Item(rw)) wertet 0 oder (this.ToDate - this.FromDate) auf 0 wertet

nicht auf die Frage bezogen, sondern this als Variablennamen verwendet, ist etwas verwirrend. Das ist meine persönliche Meinung.

0/0 ist Oveflow Ausnahme.

Answer 2

Der Fehler ist hier:

(dict_TSApplicants.Item(rw)/(this.ToDate - this.FromDate)) 

Datumsvariablen in VBA wird als verdoppelt mit dem ganzzahligen Teil des Datum und dem Dezimalteil der Zeit gespeichert.

Wenn die ToDate und FromDate am selben Tag sind, wird durch Subtraktion nur eine Dezimalzahl übrig gelassen. Teilen durch das ist das gleiche wie Multiplizieren ... so erhalten Sie einen Überlauf:

Dim OneSecond As Date 
OneSecond = TimeSerial(12, 0, 1) - TimeSerial(12, 0, 2) 
Debug.Print CDbl(OneSecond)   '-1.15740740741499E-05 
Debug.Print CDbl(1/CDbl(OneSecond)) '<-- multiplies by -86399.999999434