Simplification code VBA

Bonjour à tous !

J'ai enregistré une macro et souhaiterais de l'aide pour la simplifier !

Est-ce que quelqu'un aurait la gentillesse de m'accorder du temps ?

Pour information, je ne peux pas joindre mon fichier excel. Cependant, voici quelques précisions :

Le code permet de transposer les informations d'un formulaire vers un tableau récap (simple déplacement du contenu de plusieurs cellules vers un tableau récap).

Voici le code :

Sub versionf()
'
' versionf Macro
'

'
Sheets("Contact prestataires").Select
Rows("3:3").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("Formulaire").Select
Range("H8").Select
Selection.Copy
Sheets("Contact prestataires").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Formulaire").Select
Range("H11").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Contact prestataires").Select
Range("C3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Formulaire").Select
Range("H14").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Contact prestataires").Select
Range("D3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Formulaire").Select
Range("L11").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Contact prestataires").Select
Range("E3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Formulaire").Select
Range("L14").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Contact prestataires").Select
Range("F3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Formulaire").Select
Range("H17").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Contact prestataires").Select
Range("G3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Formulaire").Select
Range("H20").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Contact prestataires").Select
Range("H3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Formulaire").Select
Range("H23").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Contact prestataires").Select
Range("I3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Formulaire").Select
Range("L20").Select
Application.CutCopyMode = False
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Sheets("Contact prestataires").Select
Range("L3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Formulaire").Select
Range("L23").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Contact prestataires").Select
Range("M3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A3").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("B3"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(3, 9)), TrailingMinusNumbers:=True
Sheets("Formulaire").Select
Range("H8,H11,H14,H17,H20,H23,L11,L14,L20,L23").Select
Range("L23").Activate
Selection.ClearContents
End Sub

Edit modo : code à mettre entre balises avec le bouton </> merci d'y faire attention la prochaine fois

Je vous remercie par avance !

Dans l'attente de votre retour !

Bonjour Ed6888

A tester

Set wsSource = ThisWorkbookSheets("Formulaires")
Set wsDest = ThisWorkbook.Sheets("Contact prestataires")

wsDest.Rows("3:3").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
wsSource.Range("H8").Copy
wsDest.Range("A3").Select
wsDest.PasteSpecial Paste:=xlPasteValues
wsSource.Range("H11").Copy
wsDest.Range("C3").PasteSpecial Paste:=xlPasteValues
wsSource.Range("H14").Copy
wsDest.Range("D3").PasteSpecial Paste:=xlPasteValues
wsSource.Range("L11").Copy
wsDest.Range("E3").PasteSpecial Paste:=xlPasteValues
wsSource.Range("L14").Copy
wsDest.Range("F3").PasteSpecial Paste:=xlPasteValues
wsSource.Range("H17").Copy
wsDest.Range("G3").PasteSpecial Paste:=xlPasteValues
wsSource.Range("H20").Copy
wsDest.Range("H3").PasteSpecial Paste:=xlPasteValues
wsSource.Range("H23").Copy
wsDest.Range("I3").PasteSpecial Paste:=xlPasteValues
wsSource.Range("L20").Copy
wsDest.Range("L3").PasteSpecial Paste:=xlPasteValues
wsSource.Range("L23").Copy
wsDest.Range("M3").PasteSpecial Paste:=xlPasteValues
Range("A3").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("B3"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(3, 9)), TrailingMinusNumbers:=True
Sheets("Formulaire").Select
Range("H8,H11,H14,H17,H20,H23,L11,L14,L20,L23").Select
Range("L23").Activate
Selection.ClearContents]

Pardon, Manque un point sur première ligne: ThisWorkbook point Sheets

Set wsSource = ThisWorkbook.Sheets("Formulaires")

Et si besoin , ajouter déclaration de variables en entete

Dim wsSource as Worksheet
Dim wsDest as Worksheet

Bonjour Scraper,

J'ai testé avec ce code :

Sub versionf()
'
' versionf Macro
'
Dim wsSource As Worksheet
Dim wsDest As Worksheet

Set wsSource = ThisWorkbook.Sheets("Formulaires")
Set wsDest = ThisWorkbook.Sheets("Contact prestataires")

wsDest.Rows("3:3").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
wsSource.Range("H8").Copy
wsDest.Range("A3").Select
wsDest.PasteSpecial Paste:=xlPasteValues
wsSource.Range("H11").Copy
wsDest.Range("C3").PasteSpecial Paste:=xlPasteValues
wsSource.Range("H14").Copy
wsDest.Range("D3").PasteSpecial Paste:=xlPasteValues
wsSource.Range("L11").Copy
wsDest.Range("E3").PasteSpecial Paste:=xlPasteValues
wsSource.Range("L14").Copy
wsDest.Range("F3").PasteSpecial Paste:=xlPasteValues
wsSource.Range("H17").Copy
wsDest.Range("G3").PasteSpecial Paste:=xlPasteValues
wsSource.Range("H20").Copy
wsDest.Range("H3").PasteSpecial Paste:=xlPasteValues
wsSource.Range("H23").Copy
wsDest.Range("I3").PasteSpecial Paste:=xlPasteValues
wsSource.Range("L20").Copy
wsDest.Range("L3").PasteSpecial Paste:=xlPasteValues
wsSource.Range("L23").Copy
wsDest.Range("M3").PasteSpecial Paste:=xlPasteValues
Range("A3").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("B3"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(3, 9)), TrailingMinusNumbers:=True
Sheets("Formulaire").Select
Range("H8,H11,H14,H17,H20,H23,L11,L14,L20,L23").Select
Range("L23").Activate
Selection.ClearContents

End Sub

Edit modo : code à mettre entre balises avec le bouton </> merci d'y faire attention la prochaine fois

J'ai une erreur "erreur de compilation : Argument nommé introuvable" au niveau de "Paste:=" (en jaune dans le code)

Pouvez-vous me dire d'où vient le problème ?

Bonjour,

Après coup je penses avoir éliminer l'erreur mais j'ai d'autres problèmes...

Pour faciliter le travail j'ai fais un exemple

Voici les problèmes actuels :

- Lorsque la macro est exécutée plusieurs fois à la suite les infos se supprime dans le tableau (elles ne sont pas mise les une après les autres)

- Lorsque la macro est achevé, excel ne sélectionne plus la cellule H8 (début pour le prochain formulaire)

Pouvez-vous m'apporter votre aide ?

Je vous remercie par avance !

Bonjour Ed6888,

Voici ton fichier simplifié + j'ai mis des bordures et fond blanc.

@Ed6888

Je vous invite à lire la charte du forum [A LIRE AVANT DE POSTER]
qui vous aidera dans vos demandes et réponses sur ce forum et notamment :

• Pour plus de lisibilité, utilisez la fonctionnalité </> pour insérer vos codes VBA (et si possible aussi pour vos formules Excel).

Merci d'y faire attention SVP

2 corrections sur ce fil, c'est beaucoup trop

Bonjour et merci Bruno,

Deuxième versions en prenant en charge le format des cellules.

Bonjour stepaustras et merci pour votre aide.

J'ai une petite question car j'ai une erreur avec votre version 2 à ce niveau

wsSource.Range("H8").Select

"La méthode selec de la classe range a échoué"

Pouvez-vous me dire d'où vient ce problème ?

Par ailleurs, que voulez vous dire par "en prenant en charge le format des cellules"

Quelle va être la différence sans ces lignes supplémentaires ? (je ne vois pas de mon côté)

Je vous remercie infiniment pour votre aide !

Bonne fin de journée.

Bonjour Ed, rajoute ça à la fin.

wsSource.Range("H8").Select
Application.CutCopyMode = False

Bonjour stepaustras,

Merci pour ce retour !

Après coup j'ai rajouté

Sheets("Formulaire").Select

Comme ceci : (je ne sais pas vraiment si c'était ça le problème mais ça semble fonctionner !)

' Sélectionner la cellule H8 de la feuille source
Sheets("Formulaire").Select
wsSource.Range("H8").Select
Application.ScreenUpdating = True

Autre question, dans ma macro initiale, j'avais un passage qui me permettais de "diviser" l'intersection de la dernière ligne ajouté et de la colonne A. Ca ressemblait à ça :

Range("A2").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("B2"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(3, 9)), TrailingMinusNumbers:=True

Le problème est que je ne comprends pas comment adapter ce passage à votre proposition . Car pour le coup mes références A2 et et B2 ne vont me permettre de faire fonctionner la macro que pour la 1ère ligne et pas pour les suivante.

Voici le code complet que j'ai actuellement. Pouvez-vous m'aider sur ce point s'il vous plait ?

Sub versionf_simplifiee()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim DerniereLigne As Long

Application.ScreenUpdating = False
' Définir les feuilles source et de destination
Set wsSource = ThisWorkbook.Sheets("Formulaire")
Set wsDest = ThisWorkbook.Sheets("Contact prestataires")

' Trouver la dernière ligne non vide dans la colonne A de la feuille "Contact prestataires"
DerniereLigne = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1

' Copier les données de la feuille source vers la feuille de destination
wsDest.Cells(DerniereLigne, 1).Value = wsSource.Range("H8").Value
wsDest.Cells(DerniereLigne, 3).Value = wsSource.Range("H11").Value
wsDest.Cells(DerniereLigne, 4).Value = wsSource.Range("H14").Value
wsDest.Cells(DerniereLigne, 5).Value = wsSource.Range("L11").Value
wsDest.Cells(DerniereLigne, 6).Value = wsSource.Range("L14").Value
wsDest.Cells(DerniereLigne, 7).Value = wsSource.Range("H17").Value
wsDest.Cells(DerniereLigne, 8).Value = wsSource.Range("H20").Value
wsDest.Cells(DerniereLigne, 9).Value = wsSource.Range("H23").Value
wsDest.Cells(DerniereLigne, 12).Value = wsSource.Range("L20").Value
wsDest.Cells(DerniereLigne, 13).Value = wsSource.Range("L23").Value

' Copier les formats des cellules une par une
wsSource.Range("H8").Copy
wsDest.Cells(DerniereLigne, 1).PasteSpecial Paste:=xlPasteFormats
wsSource.Range("H11").Copy
wsDest.Cells(DerniereLigne, 3).PasteSpecial Paste:=xlPasteFormats
wsSource.Range("H14").Copy
wsDest.Cells(DerniereLigne, 4).PasteSpecial Paste:=xlPasteFormats
wsSource.Range("L11").Copy
wsDest.Cells(DerniereLigne, 5).PasteSpecial Paste:=xlPasteFormats
wsSource.Range("L14").Copy
wsDest.Cells(DerniereLigne, 6).PasteSpecial Paste:=xlPasteFormats
wsSource.Range("H17").Copy
wsDest.Cells(DerniereLigne, 7).PasteSpecial Paste:=xlPasteFormats
wsSource.Range("H20").Copy
wsDest.Cells(DerniereLigne, 8).PasteSpecial Paste:=xlPasteFormats
wsSource.Range("H23").Copy
wsDest.Cells(DerniereLigne, 9).PasteSpecial Paste:=xlPasteFormats
wsSource.Range("L20").Copy
wsDest.Cells(DerniereLigne, 12).PasteSpecial Paste:=xlPasteFormats
wsSource.Range("L23").Copy
wsDest.Cells(DerniereLigne, 13).PasteSpecial Paste:=xlPasteFormats

Range("A2").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("B2"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(3, 9)), TrailingMinusNumbers:=True

' Ajouter des bordures pleines aux cellules copiées
wsDest.Range(wsDest.Cells(DerniereLigne, 1), wsDest.Cells(DerniereLigne, 14)).Borders.LineStyle = xlContinuous
wsDest.Range(wsDest.Cells(DerniereLigne, 1), wsDest.Cells(DerniereLigne, 14)).Interior.ColorIndex = xlColorIndexNone

' Effacer les données de la feuille source
wsSource.Range("H8,H11,H14,H17,H20,H23,L11,L14,L20,L23").ClearContents

' Sélectionner la cellule H8 de la feuille source
Sheets("Formulaire").Select
wsSource.Range("H8").Select
Application.ScreenUpdating = True
End Sub

Je vous remercie pour votre aide !

Dans l'attente de votre retour.

Bonjour Ed,

Après ça tu l'avais déjà dans le code, mais non fonctionnel. Et cela copie que sur la ligne A2 B2 une seule fois !!!

Range("A2").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("B2"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(3, 9)), TrailingMinusNumbers:=True

Ceci est peu être mieux

Sub versionf_simplifiee()
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim DerniereLigne As Long

    Application.ScreenUpdating = False
    ' Définir les feuilles source et de destination
    Set wsSource = ThisWorkbook.Sheets("Formulaire")
    Set wsDest = ThisWorkbook.Sheets("Contact prestataires")

    With wsDest
        ' Trouver la dernière ligne non vide dans la colonne A de la feuille "Contact prestataires"
        DerniereLigne = .Cells(.Rows.Count, "A").End(xlUp).Row + 1

        ' Copier les données de la feuille source vers la feuille de destination
        .Cells(DerniereLigne, 1).Value = wsSource.Range("H8").Value
        .Cells(DerniereLigne, 3).Value = wsSource.Range("H11").Value
        .Cells(DerniereLigne, 4).Value = wsSource.Range("H14").Value
        .Cells(DerniereLigne, 5).Value = wsSource.Range("L11").Value
        .Cells(DerniereLigne, 6).Value = wsSource.Range("L14").Value
        .Cells(DerniereLigne, 7).Value = wsSource.Range("H17").Value
        .Cells(DerniereLigne, 8).Value = wsSource.Range("H20").Value
        .Cells(DerniereLigne, 9).Value = wsSource.Range("H23").Value
        .Cells(DerniereLigne, 12).Value = wsSource.Range("L20").Value
        .Cells(DerniereLigne, 13).Value = wsSource.Range("L23").Value

        ' Copier les formats des cellules une par une
        wsSource.Range("H8").Copy
        .Cells(DerniereLigne, 1).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("H11").Copy
        .Cells(DerniereLigne, 3).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("H14").Copy
        .Cells(DerniereLigne, 4).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("L11").Copy
        .Cells(DerniereLigne, 5).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("L14").Copy
        .Cells(DerniereLigne, 6).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("H17").Copy
        .Cells(DerniereLigne, 7).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("H20").Copy
        .Cells(DerniereLigne, 8).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("H23").Copy
        .Cells(DerniereLigne, 9).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("L20").Copy
        .Cells(DerniereLigne, 12).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("L23").Copy
        .Cells(DerniereLigne, 13).PasteSpecial Paste:=xlPasteFormats

        ' Effectuer une opération de découpage de texte pour chaque ligne
        For i = 2 To DerniereLigne
            wsDest.Cells(i, 1).TextToColumns Destination:=wsDest.Cells(i, 2), DataType:=xlFixedWidth, _
            FieldInfo:=Array(Array(0, 1), Array(3, 9)), TrailingMinusNumbers:=True
        Next i

        ' Ajouter des bordures pleines aux cellules copiées
        .Range(.Cells(DerniereLigne, 1), .Cells(DerniereLigne, 14)).Borders.LineStyle = xlContinuous
        .Range(.Cells(DerniereLigne, 1), .Cells(DerniereLigne, 14)).Interior.ColorIndex = xlColorIndexNone
    End With

   With wsSource
          ' Effacer les données de la feuille source
          .Range("H8,H11,H14,H17,H20,H23,L11,L14,L20,L23").ClearContents

         ' Sélectionner la cellule H8 de la feuille source
          .Range("H8").Select
   End With
   Application.ScreenUpdating = True
End Sub

Stepautras,

Merci à vous pour votre aide ainsi que votre patience !

Actuellement, j'ai une erreur à ce niveau :

            wsDest.Cells(i, 1).TextToColumns Destination:=wsDest.Cells(i, 2), DataType:=xlFixedWidth, _
            FieldInfo:=Array(Array(0, 1), Array(3, 9)), TrailingMinusNumbers:=True

A noter que je cherche juste à ce que cette étape soit effectuée sur la dernière ligne ajoutée.

Vous n'avez pas d'erreur de votre côté lorsque vous essayé la macro ?

Initialement, ma macro insérait une ligne une nouvelle ligne en haut du tableau (plus pratique à l'usage car une fois que j'ai rempli quelques "prestataires" je bascule de feuille pour réaliser de futurs étapes... Il est donc plus simple pour moi si les lignes nouvellement créées se trouve en haut du de bon tableau "contact".

Autre point que je voulais soulever, avec votre solution : les colonnes B, J et K et N se retrouve avec une police différente (idem pour la taille et la couleur de police).

Dans l'attente de votre retour.

Non je n'ai pas d'erreur re copie le code que j'ai mis

Don ça tu ne le veux pas ça sur toutes les lignes ?

   wsDest.Cells(i, 1).TextToColumns Destination:=wsDest.Cells(i, 2), DataType:=xlFixedWidth, _
            FieldInfo:=Array(Array(0, 1), Array(3, 9)), TrailingMinusNumbers:=True

Re !

Effectivement je n'ai plus l'erreur.. étrange.. j'ai du faire une mauvaise manip excusez-moi !

Je penses que votre proposition fonctionne... la présence de l'erreur m'a induit en erreur.

Je souhaite que l'étape "Effectuer une opération de découpage de texte pour chaque ligne " se fasse sur la dernière ligne créer (ce qui est le cas dans votre proposition ?) Je pensais que cette étape se répétait pour l'ensemble des lignes de ma base de données contact à chaque fois que j'ajoutais un prestataire (lourd en terme de traitement sur le long terme).

En tout cas tout fonctionne de mon côté là.

Je cherche désormais plus qu'à :

- Garder en tête de tableau les dernières lignes créées (et pas en bas si possible)

- Affecter la mise en forme des cellules de la colonne C (Par exemple) aux colonnes B, J et K et N (afin d'avoir une présentation uniforme sur l'ensemble du tableau)

Re je ne comprend la demande, au départ tu avais une erreur c'est normal, si tu rajoutes une ligne vide manuellement le code ne fonctionnera plus ! Cela n'a pas de sens de vouloir rajouter une ligne vide en haut (entre ligne 1 et 2) et ce n'est pas la bonne façon de procéder, surtout que ton tableau est filtré et que tu pourras le trier comme tu veux. Sinon tous le reste est fonctionnel (format de cellule, etc..) Tu ne copie que les formats (comme la mise en forme conditionnelle, la police, les bordures, etc.) des cellules spécifiées dans la feuille source vers la feuille de destination. Les données (le contenu des cellules) ne sont pas copiées.

PasteSpecial Paste:=xlPasteFormats

Concernant ceci c'est aussi fonctionnel, évidemment si tu rajoutes une ligne comme dis précédemment, t'auras une erreur, puisque ça commence de ligne 2 à la dernière ligne. Et des lignes en bas il y en plus de 1 million soit 1048576, pourquoi s’embêter en haut.

' Effectuer une opération de découpage de texte pour chaque ligne
        For i = 2 To DerniereLigne
            wsDest.Cells(i, 1).TextToColumns Destination:=wsDest.Cells(i, 2), DataType:=xlFixedWidth, _
            FieldInfo:=Array(Array(0, 1), Array(3, 9)), TrailingMinusNumbers:=True
        Next i

Ensuite tu peux changer la police à adapter pour toi selon.

' Ajouter des bordures pleines aux cellules copiées et changer police en Calibri 11 centré
         wsDest.Range(wsDest.Cells(DerniereLigne, 1), wsDest.Cells(DerniereLigne, 14)).Borders.LineStyle = xlContinuous
         wsDest.Range(wsDest.Cells(DerniereLigne, 1), wsDest.Cells(DerniereLigne, 14)).Interior.ColorIndex = xlColorIndexNone
         wsDest.Range(wsDest.Cells(DerniereLigne, 1), wsDest.Cells(DerniereLigne, 14)).Font.Name = "Calibri"
         wsDest.Range(wsDest.Cells(DerniereLigne, 1), wsDest.Cells(DerniereLigne, 14)).Font.Size = 11
         wsDest.Range(wsDest.Cells(DerniereLigne, 1), wsDest.Cells(DerniereLigne, 14)).HorizontalAlignment = xlCenter
         wsDest.Range(wsDest.Cells(DerniereLigne, 1), wsDest.Cells(DerniereLigne, 14)).VerticalAlignment = xlCenter

Si tu le fais sur la feuille c'est plus rapide et tu le fais qu'une fois

Bonjour Stepaustras,

Je vous remercie sincèrement pour le temps que vous m'accordez, pour vos explications et votre pédagogie ! Je débute et vous m'aidez énormément !

Suite à vos derniers messages je vous confirme que tout marche et que votre solution est en effet logique... (je ne comprenais pas tout mais ça va mieux maintenant).

Le seul point qui me chagrine encore est le suivant : j'ai vraiment besoin que les dernières lignes saisis dans le tableau contacts prestataires se trouve en tête du tableau (je vais éditer des bons d'intervention via ces contacts nouvellement créés et je ne veux pas avoir un filtrer mes résultats a chaque fois que je dois éditer ces bons --> la plus part du temps je dois éditer un bon avec un nouveau prestataire. Ce n'est que pour 1/3 voire 1/4 des cas que je dois filtrer les différentes lignes pour chercher le bon prestataire).

Je comprends que ma méthodologie initiale n'était pas correcte mais comment faire pour que je puisse avoir les dernières lignes créées en haut du tableau. Comment dois-je procéder car il s'agit d'un critère impératif pour moi ?

Dans l'attente de votre retour.

Bonsoir Ed, voici par contre il n'y aura pas de ligne vide. Le dernier enregistrement sera toujours ligne 2.

Sub versionf_simplifiee()
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim DerniereLigne As Long

    Application.ScreenUpdating = False
    ' Définir les feuilles source et de destination
    Set wsSource = ThisWorkbook.Sheets("Formulaire")
    Set wsDest = ThisWorkbook.Sheets("Contact prestataires")

    With wsDest
        ' Insérer une nouvelle ligne en haut de la feuille
        .Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

        ' Ajuster la hauteur de la ligne 2
        .Rows(2).RowHeight = 15

        ' Copier les données de la feuille source vers la nouvelle ligne en haut
        .Cells(2, 1).Value = wsSource.Range("H8").Value
        .Cells(2, 3).Value = wsSource.Range("H11").Value
        .Cells(2, 4).Value = wsSource.Range("H14").Value
        .Cells(2, 5).Value = wsSource.Range("L11").Value
        .Cells(2, 6).Value = wsSource.Range("L14").Value
        .Cells(2, 7).Value = wsSource.Range("H17").Value
        .Cells(2, 8).Value = wsSource.Range("H20").Value
        .Cells(2, 9).Value = wsSource.Range("H23").Value
        .Cells(2, 12).Value = wsSource.Range("L20").Value
        .Cells(2, 13).Value = wsSource.Range("L23").Value

        ' Copier les formats des cellules une par une
        wsSource.Range("H8").Copy
        .Cells(2, 1).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("H11").Copy
        .Cells(2, 3).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("H14").Copy
        .Cells(2, 4).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("L11").Copy
        .Cells(2, 5).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("L14").Copy
        .Cells(2, 6).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("H17").Copy
        .Cells(2, 7).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("H20").Copy
        .Cells(2, 8).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("H23").Copy
        .Cells(2, 9).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("L20").Copy
        .Cells(2, 12).PasteSpecial Paste:=xlPasteFormats
        wsSource.Range("L23").Copy
        .Cells(2, 13).PasteSpecial Paste:=xlPasteFormats

        ' Effectuer une opération de découpage de texte pour la nouvelle ligne en haut
        .Cells(2, 1).TextToColumns Destination:=.Cells(2, 2), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(3, 9)), TrailingMinusNumbers:=True

        ' Ajouter des bordures pleines aux cellules copiées
        .Range(.Cells(2, 1), .Cells(2, 14)).Borders.LineStyle = xlContinuous
        .Range(.Cells(2, 1), .Cells(2, 14)).Interior.ColorIndex = xlColorIndexNone
    End With

    ' Effacer les données de la feuille source
    With wsSource
        .Range("H8,H11,H14,H17,H20,H23,L11,L14,L20,L23").ClearContents
        ' Sélectionner la cellule H8 de la feuille source
        .Range("H8").Select
    End With

    Application.ScreenUpdating = True
End Sub