Archive qui génère automatiquement un numéro

Sub GenerateNewRecord()
Dim LastCell As Range
Dim LastNum As Long
Dim NewNum As Long

With Sheets('Database')
        Set LastCell = .Range('D65536').End(xlUp)
End With

    With Sheets('Generate')
            LastNum = Val(Right(LastCell, 5))
            NewNum = LastNum + 1
            LastCell.Offset(1, 0) = 'CP' & Format(NewNum, '00000')
            LastCell.Offset(1, 1) = .Range('D6')
            LastCell.Offset(1, 2) = .Range('D4')
            LastCell.Offset(1, 3) = .Range('D8')
            LastCell.Offset(1, 4) = .Range('D10')
            LastCell.Offset(1, 5) = .Range('D12')
    End With

End Sub

Cliquez pour agrandir...

Sub DeleteAnExistingRecord()
Dim Plage As Range, Cell As Range
Dim TheRecord As String
Dim TheMessage As String
Dim c As Byte, RowToDelete As Integer
Dim Confirmation As Byte

TheRecord = Sheets('Generate').Range('D16')
If TheRecord = '' Then Exit Sub

With Sheets('Database')
        Set Plage = .Range(.Range('D2'), .Range('D65536').End(xlUp))
End With

    For Each Cell In Plage
        If Cell = TheRecord Then
            For c = 0 To 5
                TheMessage = TheMessage & Cell.Offset(0, c) & vbCrLf
            Next
            RowToDelete = Cell.Row
            Exit For
        End If
    Next Cell
   
If Not RowToDelete = 0 Then
    Confirmation = MsgBox('Voulez vous supprimer Enregistrement suivant ?' & vbCrLf & _
                          TheMessage, vbQuestion + vbYesNo, 'Confirmation Suppression')
   
    If Confirmation = vbYes Then
        Sheets('Database').Rows(RowToDelete).EntireRow.Delete
    End If
Else
MsgBox 'Ref ' & TheRecord & ' not found !!!'

End If
End Sub

Cliquez pour agrandir...

Sub TheUser()
MsgBox Application.UserName 'Du Menu Outils Option
MsgBox Environ('UserName') 'Du Log In de NetWork/WorkStation
End Sub

Cliquez pour agrandir...

Option Explicit

Sub GenerateNewRecord()
Dim PlageToScan As Range, Cell As Range
Dim LastCell As Range
Dim LastNum As Long
Dim NewNum As Long
Dim x As Long
Dim RowToInsert As Long
Dim CellCible As Range

With Sheets('Database')
        Set LastCell = .Range('D65536').End(xlUp)
        Set PlageToScan = .Range(.Range('D2'), LastCell)
        x = Val(Right(.Cells(2, 4), 5))
End With
   
   
    For Each Cell In PlageToScan
        If Not x = Val(Right(Cell, 5)) Then
            RowToInsert = Cell.Row
            Exit For
        End If
        x = x + 1
    Next Cell


Select Case RowToInsert
Case 0
    Set CellCible = LastCell
Case Else
    With Sheets('Database')
        .Rows(RowToInsert).Insert Shift:=xlDown
        Set CellCible = .Cells(RowToInsert - 1, 4)
    End With
End Select

    With Sheets('Generate')
            LastNum = Val(Right(CellCible, 5))
            NewNum = LastNum + 1
            CellCible.Offset(1, 0) = 'CP' & Format(NewNum, '00000')
            CellCible.Offset(1, 1) = .Range('D6')
            CellCible.Offset(1, 2) = .Range('D4')
            CellCible.Offset(1, 3) = .Range('D8')
            CellCible.Offset(1, 4) = .Range('D10')
            CellCible.Offset(1, 5) = .Range('D12')
    End With

End Sub

Cliquez pour agrandir...