VBA: Créer et remplir automatiqmt des fiches

Option Explicit

Const EMBED_ATTACHMENT As Long = 1454

'A ADAPTER*****************************************
'objet du mail :
Const stSubject As String = "Envoi fiche membre"
'corps du mail
Const vaMsg As Variant = "Bonjour," & vbCrLf & vbCrLf & vbCrLf & "Voici votre fiche membre." & vbCrLf & vbCrLf & "Cordialement"
'copie à :
Const vaCopyTo As Variant = "name@mail.com"
'FIN ADAPTATIONS***********************************

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim bCpt As Byte, reponse As Integer, dest As String

If Target.Count > 1 Then Exit Sub
If Target.Column < 2 And Target.Row > 1 And Target.Row < 1500 And Target.Value <> "" Then
    If MsgBox("Voulez-vous envoyer la fiche de : " & Target.Value & "?", vbYesNo, "Envoi par mail") = vbYes Then
        With Sheets("Fiche")
            For bCpt = 3 To 9
                .Range("C" & bCpt) = Target.Offset(0, bCpt - 3)
            Next
            dest = Target.Offset(0, 7).Value
            .Copy
            Call Send_Active_Sheet(dest)
        End With
    End If
End If
End Sub


Sub Send_Active_Sheet(destinataire As String)

Dim stFileName As String
Dim vaRecipients As Variant

Dim noSession As Object
Dim noDatabase As Object
Dim noDocument As Object
Dim noEmbedObject As Object
Dim noAttachment As Object
Dim stAttachment As String

'Copy the active sheet to a new temporarily workbook.
With ActiveSheet
    .Copy
    stFileName = .Range("C3").Value
End With

stAttachment = ThisWorkbook.Path & "\" & stFileName & ".xls"

'Save and close the temporarily workbook.
With ActiveWorkbook
    .SaveAs stAttachment
    .Close
End With


'Instantiate the Lotus Notes COM's Objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GetDatabase("", "")

'If Lotus Notes is not open then open the mail-part of it.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL

'Create the e-mail and the attachment.
Set noDocument = noDatabase.CreateDocument
Set noAttachment = noDocument.CreateRichTextItem("stAttachment")
Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)

'Add values to the created e-mail main properties.
With noDocument
    .Form = "Memo"
    .SendTo = destinataire
    '.CopyTo = vaCopyTo
    .Subject = stSubject
    .Body = vaMsg
    .SaveMessageOnSend = True
    .PostedDate = Now()
    .Send 0, vaRecipients
End With

'Delete the temporarily workbook.
Kill stAttachment

'Release objects from memory.
Set noEmbedObject = Nothing
Set noAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing

MsgBox "Email crée et envoyé avec succès", vbInformation
End Sub

Sub Macro2()

Application.ScreenUpdating = False

Sheets("Données").Select
Range("A2").Select
Do Until ActiveCell.Value = ""
Nom = ActiveCell.Value
Prénom = ActiveCell.Offset(0, 1).Value
Genre = ActiveCell.Offset(0, 2).Value
Date_N = ActiveCell.Offset(0, 3).Value
Adresse = ActiveCell.Offset(0, 4).Value
CP = ActiveCell.Offset(0, 5).Value
Ville = ActiveCell.Offset(0, 6).Value

Sheets.Add.Name = Nom
Sheets("Fiche").Select
Cells.Select
Selection.Copy
Sheets(Nom).Select
ActiveSheet.Paste
Range("C3").Value = Nom
Range("C4").Value = Prénom
Range("C5").Value = Genre
Range("C6").Value = Date_N
Range("C7").Value = Adresse
Range("C8").Value = CP
Range("C9").Value = Ville
Sheets("Données").Select
ActiveCell.Offset(1, 0).Select
Loop
End Sub

• Clic droit sur l'onglet de la feuille Données
• visualiser le code
• copier-coller ce code :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim bCpt As Byte
If Target.Column < 2 And Target.Row > 1 And Target.Row < 1500 And Target.Count = 1 And Target.Value <> "" Then
    With Sheets("Fiche")
        For bCpt = 3 To 9
            .Range("C" & bCpt) = Target.Offset(0, bCpt - 3)
        Next
        .Select
    End With
End If
End Sub