Auto generate numbers

hello, I know this has been talked about many of times here but I can't find a solution that fits what I need. I have created this macro for my company and everything works great but the way I have it now each one of my locations enters there our "Collection #" in my macro. That has led to them entering duplicate numbers. I would like to be able to have the macro auto generate a number into this cell 'G2" for them starting at 0001. Then next time they open it it would enter 0002 and so on. I have tried different methods to no avail. below is the code for the macro. Thank you so much for any help.

Private Sub cmdOK_Click()

Dim ws As Worksheet
Set ws = Worksheets("Collections")

'check for a date
If Trim(Me.txtDate.Value) = "" Then
  Me.txtDate.SetFocus
  MsgBox "Please enter Todays Date"
  Exit Sub
End If

'check for their collection #
If Trim(Me.txtCollNum.Value) = "01-" Then
  Me.txtCollNum.SetFocus
  MsgBox "Please enter your Collection #"
  Exit Sub
End If

'check for a collection receipt
If Trim(Me.txtReceiptA.Value) = "" Then
  Me.txtReceiptA.SetFocus
  MsgBox "Please enter Collection Recipients Name"
  Exit Sub
End If

'check for item date
If Trim(Me.txtItem.Value) = "" Then
  Me.txtItem.SetFocus
  MsgBox "Please enter the Items Date"
  Exit Sub
End If

'check for a payer
If Trim(Me.txtPayer.Value) = "" Then
  Me.txtPayer.SetFocus
  MsgBox "Please enter a Payer"
  Exit Sub
End If

'check for description
If Trim(Me.txtDescription.Value) = "" Then
  Me.txtDescription.SetFocus
  MsgBox "Please enter a Description"
  Exit Sub
End If

'check for a amount
If Trim(Me.txtAmount.Value) = "" Then
  Me.txtAmount.SetFocus
  MsgBox "Please enter an Amount"
  Exit Sub
End If

'check for instructions
If Trim(Me.txtInstructions.Value) = "" Then
  Me.txtInstructions.SetFocus
  MsgBox "Please enter Payment Instructions"
  Exit Sub
End If

'copy the data to the form
ws.Range("A2").Value = Me.txtDate.Value
ws.Range("E2").Value = Me.txtReceiptA.Value
ws.Range("E3").Value = Me.txtReceiptB.Value
ws.Range("E4").Value = Me.txtReceiptC.Value
ws.Range("G2").Value = Me.txtCollNum.Value
ws.Range("A7").Value = Me.txtItem.Value
ws.Range("A8").Value = Me.txtCheck.Value
ws.Range("B7").Value = Me.txtPayer.Value
ws.Range("D7").Value = Me.txtDescription.Value
ws.Range("G7").Value = Me.txtDue.Value
ws.Range("H7").Value = Me.txtAmount.Value
ws.Range("B10").Value = Me.txtDestinationA.Value
ws.Range("B11").Value = Me.txtDestinationB.Value
ws.Range("B12").Value = Me.txtDestinationC.Value
ws.Range("D11").Value = Me.txtInstructions.Value

'clear the data
Me.txtDate.Value = ""
Me.txtReceiptA.Value = ""
Me.txtReceiptB.Value = ""
Me.txtReceiptC.Value = ""
Me.txtCollNum.Value = ""
Me.txtItem.Value = ""
Me.txtCheck.Value = ""
Me.txtPayer.Value = ""
Me.txtDescription.Value = ""
Me.txtDue.Value = ""
Me.txtAmount.Value = ""
Me.txtDestinationA.Value = ""
Me.txtDestinationB.Value = ""
Me.txtDestinationC.Value = ""
Me.txtInstructions.Value = ""
Me.txtDate.SetFocus

 Unload Me

End Sub

Ok so I found this code and it works but when I close the workbook and reopen it it asks me to enter a number to start with again. It is not saving the count so it restarts everytime. how can I get this to save so it will work? Below is the code.

Option Explicit
 
Private Sub Workbook_Open()
     
    Dim x As String
    On Error GoTo ErrorHandler
    
One:
    Open "c:\" & ThisWorkbook.Name & _
    " Counter.txt" For Input As #1
    Input #1, x
    Close #1
    x = x + 1
     
Two:
    Sheets(1).Range("G2").Value = x
    Open "C:\" & ThisWorkbook.Name & _
    " Counter.txt" For Output As #1
    Write #1, x
    Close #1
     
    Exit Sub
     
ErrorHandler:
    Select Case Err.Number
    
'If Counter file does not exist...
    Case 53
NumberRequired:
        x = InputBox("Enter a Collection Number greater than " & _
        "999 to Begin Collecting With", _
        "Create 'C:\" & ThisWorkbook.Name & _
        " Counter.txt' File")
        If Not IsNumeric(x) Then GoTo NumberRequired
        If x <= 0 Then GoTo NumberRequired
        Resume Two
    Case Else
        Resume Next
    End Select
End Sub