在3D數組中循環訪問vba不返回所有結果

Question

我有一個項目，其中有4個與4個「合約」日期相關的預定付款，存儲在tblPaySch中但是，有時我們收到的付款（存儲在tblTrans中）日期（「實際」）日期

我正在嘗試一個數組，它定義了4個日期（由ID 1 - 4標識）和預期金額，然後將其與tblTrans進行比較以查看預期付款是否超過，如果是，則將該交易日期標記爲「實際」日期。

可能是我的數組有問題或者我的循環出了問題，因爲我可以得到ID1的結果（即關聯預期工資和符合它的交易日期），但無法獲得其他結果3個ID。

我在GetDate（prjID）的查詢中調用它來將prjId傳遞給該函數。

這裏是我的代碼：

'This function is a multidimensional array that can hold multiple values 
Public Function GetDate(intID As Long) As Variant 

    Dim intTot As Long 
    Dim i As Integer 
    Dim i2 As Integer 

    'Define recordset to get expected payment data 
    Dim rsPrj As DAO.Recordset 
    Set rsPrj = CurrentDb.OpenRecordset("SELECT * FROM tblPaySch WHERE PrjID =" & intID, dbOpenSnapshot) 

    'Define recordset to get transaction data 
    Dim rs As DAO.Recordset 
    Set rs = CurrentDb.OpenRecordset("Select * from tblTrans where PrjID=" & intID, dbOpenSnapshot) 


    'Store milestone payments in RA 
    Dim RA(0 To 4, 0 To 4, 0 To 4) As Variant 
    RA(0, 0, 0) = rsPrj!MSCdbID 'payment Id, 4 of which are associated with each PrjID 
    RA(0, 1, 0) = rsPrj!PayIncGST 'expected payment amount, of 4 different totals 
    RA(0, 0, 1) = rs!RefDate 'Actual date from tblTrans 
    intTot = 0 

    Do While rs.EOF 
     intTot = intTot + rs!Amt 'refers to the amount of the transaction 
     '-----Check for milestone exceeded 
     For i = 0 To 4 
      For i2 = 0 To 4 
       If IsNull(RA(i, i2, 1) And RA(i, i2, 0) <= intTot) Then 
         RA(i, i2, 1) = rs!RefDate 
       End If 
      Next i2 
     Next i 

    Loop 

    GetDate = RA(0, 0, 1) 

    Debug.Print RA(1, 0, 0) 
    Debug.Print RA(0, 1, 0) 
    Debug.Print RA(0, 0, 1) 

End Function 

預先感謝您了，請原諒任何明顯的失誤noobie，這是我第一次陣列功能。

Answer 1

好吧，我想我明白你在做什麼。讓我們看看我們是否可以簡化這一點。

首先，你有你的表結構（DatePaid是要更新的價值？）：

tblPaySch是：

PrjID PayID ExpectedAmt DatePaid(trying to find from tblTrans) 
1   1   $100 
1   2   $150 
1   3   $100 
1   4   $200 

tblTrans是：（假定日期格式爲DD/MM/YYYY且始終按時間順序排序）

PrjID AmtPaid PayDate 
1  $250 12/03/12 
2  $765 05/05/12 
3  $150 06/05/12 
1  $200 07/06/12 
1  $100 08/07/12 

我認爲它可以tak e多次交易以達到預期的付款金額，但付款額也可能高於預期。我使用了您在示例數據中給出的字段名稱的列名稱。

我希望爲代碼添加了足夠的評論，以便對您有用。

Private Function GetDate(intID As Long) As Variant 
    Dim intTot As Long 
    Dim i As Integer 
    Dim i2 As Integer 
    Dim loopCounter As Integer 

    'Define recordset to get expected payment data 
    Dim rsPrj As DAO.Recordset 
    Set rsPrj = CurrentDb.OpenRecordset("SELECT * FROM tblPaySch WHERE PrjID =" & intID) 

    'Define recordset to get transaction data 
    Dim rs As DAO.Recordset 
    Set rs = CurrentDb.OpenRecordset("Select * from tblTrans where PrjID=" & intID, dbOpenSnapshot) 

    ' get rs.recordcount and go back to the beginning 
    rs.MoveLast 
    rs.MoveFirst 

    ' Only need to store the records returned and the 2 fields Payment amount and payment date 
    Dim RA() As Variant 
    ReDim RA(0 To rs.RecordCount - 1, 0 To 1) 

    ' Populate the array with the transaction records 
    i = 0 
    Do Until rs.EOF 
     RA(i, 0) = rs!AmtPaid 
     RA(i, 1) = rs!PayDate 
     If rs.RecordCount <> 0 Then 
      rs.MoveNext 
      i = i + 1 
     End If 
    Loop 

    intTot = 0 
    loopCounter = 0 ' This will ensure we don't check transactions more than once 

    ' First we're going to loop through the payment schedule and see at which payment from table transaction 
    ' the scheduled payment is met 
    Do Until rsPrj.EOF 
     ' First we check if the last payment was enough to make this scheduled payment to and if so mark it paid 
     ' otherwise check for the next transaction that gives us enough 
     If intTot < rsPrj!ExpectedAmt Then 
      For i = loopCounter To UBound(RA) 
       intTot = intTot + RA(i, 0) 
       If intTot >= rsPrj!ExpectedAmt Then ' if the current payment is = or greater than expected set the date 
        rsPrj.edit 
        rsPrj!DatePaid = RA(i, 1) 
        rsPrj.Update 
        intTot = intTot - rsPrj!ExpectedAmt ' update our remainder 
        loopCounter = loopCounter + 1 ' increase this so we don't double check a transaction 
        Exit For ' exit loop and move to the next expected payment 
       End If 
      Next i 
     Else 
      rsPrj.edit 
      rsPrj!DatePaid = RA(i, 1) 
      rsPrj.Update 
      intTot = intTot - rsPrj!ExpectedAmt 
     End If 
     If rsPrj.RecordCount <> 0 Then 
      rsPrj.MoveNext 
     End If 
    Loop 
End Function