フィールド値に基づいてアクセステーブルに可変数のレコードを挿入する方法

Question

アクセステーブルにWeeklyID（PrimaryKey）、CampaignID（Foreignkey）、WeekEnded（Dateフィールド）、Duration（Numberフィールド）。

テーブルにX個のレコードを自動的に追加したいとします。ここで、Xは[期間]フィールドに格納されている番号です。追加されたレコードの元のレコードと同じCampaignIDが必要です。自動化されたプロセスは、特定のCampaignIDを持つレコードの数がDurationの数と等しい場合に満たされます。

誰でもこれを達成するための支援を提供できれば、非常に感謝しています。さらに詳しい情報が必要な場合は、お問い合わせください！

Answer 1

ここでそれを行うための一つの方法です。レコードを追加した後に誰かが期間を変更するシナリオを計画していたことに注意してください。

Option Compare Database 
Option Explicit 

Dim dbs  As DAO.Database 
Dim rs  As DAO.recordSet 
Dim rsOT As DAO.recordSet 

Function Create_New_Rows() 
Dim strSQL   As String 
Dim i    As Integer 
Dim iAdd   As Integer 
Dim iDuration  As Integer 
Dim lCampaignID  As Long 


    On Error GoTo Error_trap 

    Set dbs = CurrentDb 

    strSQL = "SELECT Count(Campaign.WeeklyID) AS NbrRecs, First(Campaign.Duration) AS Duration, Campaign.CampaignID " & _ 
       "FROM Campaign " & _ 
       "GROUP BY Campaign.CampaignID;" 
    Set rs = dbs.OpenRecordset(strSQL) 
    Set rsOT = dbs.OpenRecordset("Campaign") 
    If rs.EOF Then 
     MsgBox "No records found!", vbOKOnly + vbCritical, "No Records" 
     GoTo Exit_Code 
    Else 
     rs.MoveFirst 
    End If 

    Do While Not rs.EOF 
     Debug.Print "Campaign: " & rs!CampaignID & vbTab & "Duration: " & rs!Duration & vbTab & "# Recs: " & rs!NbrRecs 
     iDuration = rs!Duration 
     lCampaignID = rs!CampaignID 


     ' Check if already have correct number of records for this ID 
     If iDuration = rs!NbrRecs Then 
      ' Do nothing... counts are good 
     ElseIf iDuration < rs!NbrRecs Then 
      MsgBox "Add code to resolve too many records for Campaign: " & lCampaignID & vbCrLf & _ 
       "Duration: " & iDuration & vbCrLf & _ 
       "Records: " & rs!NbrRecs, vbOKOnly + vbCritical, "Too many records already!" 
     Else 
      ' Finally, Duration is less than existing records... time to add... 
      iAdd = iDuration - rs!NbrRecs 
      Do 
       If iAdd > 0 Then 
        ' Add new record 
        Add_Records lCampaignID 
        iAdd = iAdd - 1 
       Else 
        Exit Do 
       End If 
      Loop 
     End If 
     rs.MoveNext 
    Loop 

Exit_Code: 
    If Not rs Is Nothing Then 
     rs.Close 
     Set rs = Nothing 
    End If 
    If Not rsOT Is Nothing Then 
     rsOT.Close 
     Set rsOT = Nothing 
    End If 
    dbs.Close 
    Set dbs = Nothing 

    MsgBox "Finished" 

    Exit Function 
Error_trap: 
    Debug.Print Err.Number & vbTab & Err.Description & vbCrLf & "In: Create_New_Rows" 
    MsgBox Err.Number & vbTab & Err.Description & vbCrLf & "In: Create_New_Rows" 
    Resume Exit_Code 
    Resume 
End Function 

Function Add_Records(lCampID As Long) 
    With rsOT 
     .AddNew 
     !CampaignID = lCampID 
     ' Add code if you want to populate other fields... 
     .Update 
     'Debug.Print "Added rec for CampaingID: " & lCampID 
    End With 

End Function 

Answer 2

あなたは固定値としてlngCountを持っているために、この機能を変更することができます。

Public Sub CopyEmptyRecords() 

    Dim rstSource As DAO.Recordset 
    Dim rstInsert As DAO.Recordset 
    Dim fld   As DAO.Field 
    Dim strSQL  As String 
    Dim lngLoop  As Long 
    Dim lngCount As Long 
    Dim booCopy  As Boolean 

    strSQL = "SELECT * FROM tblStats" 
    Set rstSource = CurrentDb.OpenRecordset(strSQL) 

    strSQL = "SELECT TOP 1 * FROM tblStatsNull" 
    Set rstInsert = CurrentDb.OpenRecordset(strSQL) 

    With rstSource 
    .MoveLast 
    .MoveFirst 
    lngCount = .RecordCount   ' Set to fixed value of 7. 
    For lngLoop = 1 To lngCount 
     With rstInsert 
     booCopy = False 
     .AddNew 
      For Each fld In rstSource.Fields 
      With fld 
       If .Attributes And dbAutoIncrField Then 
       ' Skip Autonumber or GUID field. 
       Else 
       ' Copy field content. 
       rstInsert.Fields(.Name).Value = .Value 
       If Len(Trim(Nz(.Value, vbNullString))) = 0 Then 
        booCopy = True 
       End If 
       End If 
      End With 
      Next 
     If booCopy = True Then 
      .Update 
     Else 
      .CancelUpdate 
     End If 
     End With 
     .MoveNext 
    Next 
    rstInsert.Close 
    .Close 
    End With 

    Set rstInsert = Nothing 
    Set rstSource = Nothing 

End Sub