Distributed ID

[guest 73]

Hi everyone,
I have a userform wher i use a unique ID and two option buttons.
I would like to distribute the data in two tables. If optionbutton 1 is true then data goes in table 1 and if optionbutton 2 is true then data goes in table two. The Id number lose it's count when data goes in table 2 and restart from 1.
Any help?
Here the code and the userform

Private Sub CommandButton1_Click()

Dim LstRw As Long
LstRw = Cells(Rows.Count, "A").End(xlUp).Row
Me.TextBox1.Value = Cells(LstRw, "A").Value + 1
TextBox3.Value = Format(Now(), "dd-mm-yy _ hh:mm")
End Sub

Private Sub CommandButton2_Click()
If TextBox2 = "" Then
MsgBox ("Appuyer sur Nouveau")
Else
If Sheets("Feuil1").Range("A1") = "" Then
Sheets("Feuil1").Range("A1") = TextBox1
Else
Sheets("Feuil1").ListObjects(1).ListRows.Add
End If
dlt = Sheets("Feuil1").Range("A1048576").End(xlUp).Row
If OptionButton1.Value = True Then
Sheets("Feuil1").Range("A" & dlt) = TextBox1
Sheets("Feuil1").Range("B" & dlt) = TextBox2
Sheets("Feuil1").Range("C" & dlt) = TextBox3
Else
Sheets("Feuil1").Range("F" & dlt) = TextBox1
Sheets("Feuil1").Range("G" & dlt) = TextBox2
Sheets("Feuil1").Range("H" & dlt) = TextBox3
End If
End If
End Sub

Private Sub TextBox3_Change()
TextBox3.Value = Format(Now(), "dd/mm/yy _ hh:mm")
End Sub

 

[GWteB]

In your code occasionally empty lines are added to your table, while this is not necessary. The principle of a ListObject is that Excel automatically extends the range when data is added to the bottom. The red marked line in your code always delivers the bottom row of the table, regardless of whether it is empty or not. Empty equals to "" or 0, so your numbering starts over again.

Private Sub CommandButton1_Click()
    Dim LstRw As Long
    LstRw = Cells(Rows.Count, "A").End(xlUp).Row
    Me.TextBox1.Value = Cells(LstRw, "A").Value + 1
    TextBox3.Value = Format(Now(), "dd-mm-yy _ hh:mm")
End Sub

 

[guest 73]

In your code occasionally empty lines are added to your table, while this is not necessary. The principle of a ListObject is that Excel automatically extends the range when data is added to the bottom. The red marked line in your code always delivers the bottom row of the table, regardless of whether it is empty or not. Empty equals to "" or 0, so your numbering starts over again.

Private Sub CommandButton1_Click()
    Dim LstRw As Long
    LstRw = Cells(Rows.Count, "A").End(xlUp).Row
    Me.TextBox1.Value = Cells(LstRw, "A").Value + 1
    TextBox3.Value = Format(Now(), "dd-mm-yy _ hh:mm")
End Sub

So? Is there a solution to that? Hoe can i fix it?

 

[GWteB]

The easiest way to solve this would be to store the ID in a cell on a (hidden) worksheet. Because you are using tables, I have chosen to approach it differently. A separate function reads from each table the last ID numbers used and returns the highest number. As you can see, I maintain your approach by first expanding the table at the bottom and then copying the data. However, no rows are added if there are still empty rows at the bottom of the table. Furthermore, I have written the code in such a way that it does not matter where your tables are located on the worksheet. In this regard, note the two separate functions, to be placed in a standard module.
GetLastUsedRow returns the bottom non-empty row in a table, regardless of whether or not there are empty rows below it within that table.
GetBottomRow returns the bottom row in a table, regardless of whether it contains data or not.
Hopefully this is of some help.

Userform module:

Private Sub UserForm_Initialize()
    Me.OptionButton1.Value = True
End Sub


Private Function GetID() As Long

    Dim oLo As ListObject, lOne As Long, lTwo As Long

    With ThisWorkbook.Sheets("Feuil1")

        Set oLo = .ListObjects("Table1")
        On Error Resume Next  ' <<< ignore non-numeric values
        lOne = .Cells(GetLastUsedRow(oLo), oLo.HeaderRowRange.Column).Value
        On Error GoTo 0
        
        Set oLo = .ListObjects("Table2")
        On Error Resume Next  ' <<< ignore non-numeric values
        lTwo = .Cells(GetLastUsedRow(oLo), oLo.HeaderRowRange.Column).Value
        On Error GoTo 0

        GetID = Application.WorksheetFunction.Max(lOne, lTwo)
    End With
End Function


Private Sub CommandButton1_Click()

    Me.TextBox1.Value = GetID + 1

    TextBox3.Value = Format(Now(), "dd-mm-yy _ hh:mm")
End Sub


Private Sub CommandButton2_Click()

    Dim oLo As ListObject, lNewRow As Long, lErr As Long
    
    If TextBox2 = "" Then
        MsgBox ("Appuyer sur Nouveau")
    Else
        With ThisWorkbook.Sheets("Feuil1")
            If OptionButton1.Value = True Then
                Set oLo = .ListObjects("Table1")
            ElseIf OptionButton2.Value = True Then
                Set oLo = .ListObjects("Table2")
            Else
                Exit Sub
            End If

            lNewRow = GetLastUsedRow(oLo) + 1
            If (lNewRow - 1) >= GetBottomRow(oLo) Then
                On Error Resume Next
                oLo.ListRows.Add
                lErr = Err.Number
                Err.Clear
                On Error GoTo 0
                If lErr <> 0 Then
                    MsgBox "Unable to add a row on table " & oLo.DisplayName & vbNewLine & _
                           "An attempt to shift some cells failed.", vbExclamation, Me.Caption
                    Exit Sub
                End If
            End If
            .Cells(lNewRow, oLo.HeaderRowRange.Column) = TextBox1
            .Cells(lNewRow, oLo.HeaderRowRange.Column).Offset(0, 1) = TextBox2
            .Cells(lNewRow, oLo.HeaderRowRange.Column).Offset(0, 2) = TextBox3
        End With
    End If
End Sub

Standard module:

Public Function GetLastUsedRow(ByVal argTable As ListObject) As Long
    If Not argTable Is Nothing Then
        GetLastUsedRow = argTable.Range.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    End If
End Function

Public Function GetBottomRow(ByVal argTable As ListObject) As Long
    If Not argTable Is Nothing Then
        If Not argTable.DataBodyRange Is Nothing Then
            GetBottomRow = argTable.DataBodyRange.Rows.Count + argTable.HeaderRowRange.Row
        Else
            GetBottomRow = argTable.HeaderRowRange.Row + 1
        End If
    End If
End Function

 

[guest 73]

Hi GWteB,
Thank you very much for your response and for the time you spend on that, Chapeau.
I did try your code and there is a small problem witch i cant identify.
If i select the option button 1 nothing hapend, no error,no save in the table.
With option button 2 work beautiful.
If i dont abuse of your kindness please help me with that.
Thank you again

 

[GWteB]

That's some kind of odd, since I tested the code on existing and newly created (blank) tables anywhere on the sheet and it worked for me.
Please check if this part in the CommandButton2_Click procedure is consistent with the names of your userform controls.

        With ThisWorkbook.Sheets("Feuil1")
            If OptionButton1.Value = True Then
                Set oLo = .ListObjects("Table3")
            ElseIf OptionButton2.Value = True Then
                Set oLo = .ListObjects("Table4")
            Else
                Exit Sub
            End If

It could be the cause of your issue. If it's not we must dig deeper but I'm sure that otherwise a run-time error had been occurred due to a unreferenced oLo variabele (=Nothing).

 

[guest 73]

Sorry, my bad, i changed the names of tables and is working beautiful. Thanks again and again.
I wish you best. Merry Christmas and Happy New Year!

 

[GWteB]

You are welcome and thanks for the feedback. Same wishes to you too.