Option Explicit
Sub travdem()
Dim Cellule1 As Range, Plg1 As String, Dl1 As Long, Dl2 As Long, Plg3 As Range
Dim Nomfeuille1 As String, Col1 As String
Dim MonTab As Variant, Compt1 As Long
'parametre
Nomfeuille1 = "Base"
Col1 = "A"
'code
With Sheets(Nomfeuille1)
Select Case MsgBox("Les données seront recopiées à partir de la ligne active " _
& vbCrLf & "ligne active : " & ActiveCell.Row _
& vbCrLf & "" _
, vbYesNo Or vbExclamation Or vbDefaultButton1, "Ligne de départ")
Case vbYes
Select Case MsgBox("Les données seront recopiées à partir de la ligne " & ActiveCell.Row _
& vbCrLf & "" _
& vbCrLf & "Veuillez confirmer " _
& vbCrLf & "" _
& vbCrLf & "" _
, vbYesNo Or vbExclamation Or vbDefaultButton1, "Départ")
Case vbYes
Dl2 = ActiveCell.Row
Case vbNo
Exit Sub
End Select
Case vbNo
Exit Sub
End Select
Set Plg3 = .Range(Col1 & Dl2 & ":" & Col1 & .Range(Col1 & .Rows.Count).End(xlUp).Row)
'vérification de l'existance de la feulle
For Each Cellule1 In Plg3
If FeuillePresente(Cellule1.Value) = False Then
Call MsgBox("La feuille : " & Cellule1.Value & " n'existe pas" _
& vbCrLf & "Ligne :" & Cellule1.Row _
, vbCritical, Application.Name)
Exit Sub
End If
Next Cellule1
'recopie des données
For Each Cellule1 In Plg3
Dl1 = Sheets(Cellule1.Value).Range(Col1 & Sheets(Cellule1.Value).Rows.Count).End(xlUp).Row + 1
.Range("a" & Cellule1.Row & ":" & "h" & Cellule1.Row).Copy _
Destination:=Worksheets(Cellule1.Value).Range("A" & Dl1)
Next Cellule1
End With
End Sub
Private Function FeuillePresente(NomFeuille As String) As Boolean
Dim Sh As Worksheet
For Each Sh In Worksheets
If Sh.Name = NomFeuille Then
FeuillePresente = True
Exit Function
End If
Next Sh
End Function