Automatically Assign ID Number to Set of Records and Loop Until End

Anonymous
2010-11-14T17:08:07+00:00

I am a beginner so any assistance I receive will need to be specific with examples. I can't yet go from the abstract idea and turn that into hard code.

I have two queries (separate because I do not know how to make them into one). The first query exports the top 30 records into a table, then I manually run the second query to update the source table with the resultant ID number. I have thousands of records and I'd like to be able to put code behind a button that:

  • Assigns the top 30 records and does the SELECT INTO (Instead of the prompt the user will choose the city name from a combo box which I now know how to design.)
  • Updates the source table with the ID number
  • Loops until the end but on the last record assign ALL remaining records to the last ID number.  I have already determined exactly how many records need to be created manually. I have a report that tells me how many ID numbers I will need based on dividing the recordset into 30. I then bulk create those IDs.

BONUS: Have Access determine how many IDs I need and then assign the records and create the exports as text files with the name 'export1', 'export2' or 'export' & 'resultantidnumber', etc.

qryEXPStreetsandTrips:

SELECT TOP 30 tblSurveyData.SurveyID, tblSurveyData.FullName, IIf(tblSurveyData.Address2="1/2",[StNumber] & " " & [Address2] & " " & tblSurveyData.StName,[tblSurveyData].[StNumber] & " " & [tblSurveyData].[StName]) AS Address, IIf([tblSurveyData].[Apt?]=-1,"Apt. ",IIf([tblSurveyData].[Room?]=-1,"Room ",IIf([tblSurveyData].[Studio?]=-1,"Studio ",IIf([tblSurveyData].[Suite?]=-1,"Suite ",IIf([tblSurveyData].[Unit?]=-1,"Unit ",IIf([tblSurveyData].[Space?]=-1,"Space ",IIf([tblSurveyData].[Lot?]=-1,"Lot ",IIf([tblSurveyData].[Bldg?]=-1,"Bldg ",IIf([tblSurveyData].[Floor?]=-1,"Floor ",Null))))))))) & [Address2] AS Addr2, tblCity.City, tblSurveyData.Zip, CLng([Enter the territoryID to assign:]) AS TerritoryID INTO EXPStreetsandTrips

FROM tblSurveyData LEFT JOIN tblCity ON tblSurveyData.CityID = tblCity.CityID

WHERE (((tblCity.City) Like [Enter the city name:] & "*") AND ((tblSurveyData.TerritoryID)=106) AND ((tblSurveyData.TerritoryTypeID)=3))

ORDER BY tblSurveyData.Zip, tblSurveyData.Latitude;

qrySurveyData SET Survey (I have to wait a few seconds until the EXPStreetsandTrips is created before launching this query or it won't work, of course):

UPDATE tblSurveyData INNER JOIN EXPStreetsandTrips ON tblSurveyData.SurveyID=EXPStreetsandTrips.SurveyID SET tblSurveyData.TerritoryID = [EXPStreetsandTrips].[TerritoryID]

WHERE (((tblSurveyData.TerritoryID)=106) And ((tblSurveyData.SurveyID)=EXPStreetsandTrips.SurveyID) And ((tblSurveyData.TerritoryTypeID)=3));

Microsoft 365 and Office | Access | For home | Windows

Locked Question. This question was migrated from the Microsoft Support Community. You can vote on whether it's helpful, but you can't add comments or replies or follow the question.

0 comments
Answer accepted by question author
HansV 462.7K Reputation points MVP Volunteer Moderator
2010-11-17T19:18:13+00:00

Here is a new version that exports text files. Before testing it, change the export path in the variable strPath. It MUST end in a backslash.

Private Sub cmdAssignTest_Click()

  Dim strCongregationID As String

  Dim strUserID As String

  Dim lngBatchSize As Long

  Dim lngOldTerritoryID As Long

  Dim lngNewTerritoryID As Long

  Dim dbs As DAO.Database

  Dim rst As DAO.Recordset

  Dim rst2 As Recordset

  Dim strSQL As String

  Dim lngRecordCount As Long

  Dim lngCurrentRecord As Long

  Dim strTerritoryName As String

  Dim lngTerritoryNumber As Long

  Dim f As Integer

  Dim strPath As String

  Dim strLine As String

  Dim strDelimiter As String

  On Error GoTo ErrHandler

  ' Change these as needed

  ' Batch size

  lngBatchSize = 30

  ' Unassigned ID

  lngOldTerritoryID = 106

  ' Path for text files

  strPath = "C:\Surveys"

  ' Delimiter for text files

  strDelimiter = vbTab ' can also be ","

  ' Get some info

  strCongregationID = DLookup("CongregationID", "tblVar")

  strUserID = DLookup("UserID", "tblVar")

  strTerritoryName = Nz(Me.TerritoryName, InputBox("Please provide a name for the new territory"))

  ' Get number of unassigned survey records

  strSQL = "SELECT * FROM tblSurveyData WHERE CityID=" & strCityID & _

    " AND TerritoryTypeID=" & strTerritoryTypeID & _

    " AND TerritoryID=" & lngOldTerritoryID

  Set dbs = CurrentDb

  Set rst = dbs.OpenRecordset(strSQL, dbOpenDynaset)

  If rst.EOF Then

    MsgBox "No records!", vbExclamation

    GoTo ExitHandler

  End If

  rst.MoveLast

  rst.MoveFirst

  lngRecordCount = rst.RecordCount

  f = FreeFile

  ' Get highest TerritoryNumber

  lngTerritoryNumber = Nz(DMax("TerritoryNumber", "tblTerritory", _

    "CityID=" & strCityID & " AND TerritoryTypeID=" & strTerritoryTypeID), 0)

  Set rst2 = dbs.OpenRecordset("tblTerritory", dbOpenDynaset)

  ' Loop

  lngCurrentRecord = 0

  Do While Not rst.EOF

    lngCurrentRecord = lngCurrentRecord + 1

    If lngCurrentRecord Mod lngBatchSize = 1 Then

      ' Do we have enough records left?

      If lngRecordCount - lngCurrentRecord >= lngBatchSize \ 2 _

          Or lngCurrentRecord = 1 Then

        ' Create new territory

        lngTerritoryNumber = lngTerritoryNumber + 1

        rst2.AddNew

        rst2!TerritoryNumber = lngTerritoryNumber

        rst2!TerritoryTypeID = strTerritoryTypeID

        rst2!CityID = strCityID

        rst2!CongregationID = strCongregationID

        rst2!EnteredBy = strUserID

        rst2!TerritoryName = strTerritoryName

        ' Remember new ID

        lngNewTerritoryID = rst2!TerritoryID

        rst2.Update

        ' Close previous text file

        If lngCurrentRecord > 1 Then

          Close #f

        End If

        ' Open new text file

        Open strPath & "Territory" & lngNewTerritoryID & ".txt" For Output As #f

      End If

    End If

    ' Assign territory

    rst.Edit

    rst!TerritoryID = lngNewTerritoryID

    rst.Update

    ' Build line for text file

    strLine = rst!SurveyID & strDelimiter & Chr(34) & rst!FullName & Chr(34) & _

      strDelimiter & Chr(34) & rst!StNumber & " "

    If rst!Address2 = "1/2" Then

      strLine = strLine & rst!Address2 & " "

    End If

    strLine = strLine & rst!StName & Chr(34) & strDelimiter & Chr(34)

    Select Case True

      Case rst![Apt?]

        strLine = strLine & "Apt. "

      Case rst![Room?]

        strLine = strLine & "Room "

      Case rst![Studio?]

        strLine = strLine & "Studio "

      Case rst![Suite?]

        strLine = strLine & "Suite "

      Case rst![Unit?]

        strLine = strLine & "Unit "

      Case rst![Space?]

        strLine = strLine & "Space "

      Case rst![Lot?]

        strLine = strLine & "Lot "

      Case rst![Bldg?]

        strLine = strLine & "Bldg "

      Case rst![Floor?]

        strLine = strLine & "Floor "

    End Select

    strLine = strLine & rst!Address2 & Chr(34) & strDelimiter & _

      Chr(34) & DLookup("City", "tblCity", "CityID=" & strCityID) & Chr(34) & _

      strDelimiter & rst!Zip & strDelimiter & lngNewTerritoryID

    ' Write line to file

    Print #f, strLine

    ' On to the next record

    rst.MoveNext

  Loop

ExitHandler:

  On Error Resume Next

  Close #f

  rst.Close

  rst2.Close

  Set dbs = Nothing

  Me.Requery

  Exit Sub

ErrHandler:

  MsgBox Err.Description, vbExclamation

  Resume ExitHandler

End Sub

Was this answer helpful?

0 comments

41 additional answers

Sort by: Most helpful
Most helpful Newest Oldest
  1. Anonymous
    2010-11-18T18:20:30+00:00

    Thanks!

    Was this answer helpful?

    0 comments