我正在创建一些程序来根据一些数据和用户输入生成报告。代码复制基本报告的必要信息，然后我有一个附加的工作表，其中包含我最初复制后要添加到报告中的时间序列数据。
这段代码在经过几次迭代后产生溢出：
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
对于上下文，它包含在此类模块中 - 循环位于底部的InsertTSData()子例程中：
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
答案 0 :(得分：2)
在这两行中
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))
在dict_TSApplicants.Item(rw)返回0后，dict_TSViews.Item(rw))计算结果为0或(this.ToDate - this.FromDate)计算结果为0.
与此问题无关，但使用this作为变量名称有点令人困惑。这是我的个人意见。
0/0是Oveflow例外。
答案 1 :(得分：0)
错误在于：
(dict_TSApplicants.Item(rw) / (this.ToDate - this.FromDate))
VBA中的日期变量存储为双精度数，整数部分为日期，小数部分为时间。
如果ToDate和FromDate在同一天，减去它们只会留下小数。除以这与乘法相同......所以你得到溢出：
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