Re : Copier coller suivant plusieurs critères
Bon allez un petit effort supplémentaire : Contrôle de l'existence de la feuille
Remplace le code du module 1 par celui-ci
Teste en remplaçant, par exemple : SMG par toto
Sub copieInscrit()
Randomize
Dim NomFeuille As String, Reponse As Boolean
Application.ScreenUpdating = False
Dim tab_bd()
Dim tab_insc()
Sheets("Internationale_des_3_Routes").Activate
A = ActiveSheet.Name
derli = Sheets("Internationale_des_3_Routes").Range("A65536").End(xlUp).Row
ReDim tab_bd(derli - 1, 17)
tab_bd() = Range("B2:R" & derli)
derli = Sheets("Feuil1").Range("B65536").End(xlUp).Row
ReDim tab_insc(derli - 1, 2)
Sheets("Feuil1").Activate
tab_insc() = Range("B3:C" & derli)
'MsgBox LBound(tab_bd, 1) '=> renvoie : 10
Windows("Inscrits.xls").Activate
For Each Feuille In ActiveWorkbook.Sheets
For j = LBound(tab_insc, 1) To UBound(tab_insc, 1)
Feuille = tab_insc(j, 2)
' Stop
NomFeuille = Feuille
Reponse = FeuilleExiste(NomFeuille)
If Reponse = False Then MsgBox ("La feuille " & NomFeuille & " n'existe pas , veuillez la créer "): Exit Sub
With Sheets(Feuille)
derli = Sheets(Feuille).Range("E65536").End(xlUp).Row
If derli < 5 Then derli = 5
.Range("B5:R" & derli).ClearContents
End With
Next j
Next Feuille
' Stop
For n = LBound(tab_bd, 1) To UBound(tab_bd, 1)
'Stop
cat = tab_bd(n, 8)
'If cat = "PF" Then Stop
For j = LBound(tab_insc, 1) To UBound(tab_insc, 1)
If cat = tab_insc(j, 1) Then
Feuille = tab_insc(j, 2)
Exit For
End If
Next j
'Stop
With Sheets(Feuille)
derli = Sheets(Feuille).Range("E65536").End(xlUp).Row + 1
If derli < 4 Then derli = 4
For m = 2 To 18
.Cells(derli, m) = tab_bd(n, m - 1)
Next
End With
Next
'Stop
End Sub
Function FeuilleExiste(MaFeuille As String) As Boolean
Dim Feuil As Worksheet
FeuilleExiste = False
For Each Feuil In Worksheets
If (Feuil.Name = MaFeuille) Then
FeuilleExiste = True
End If
Next Feuil
End Function