Diviser une procédure

Bonjour la communauté !!

J'ai une question très importante ! en fait j'ai codé une procédure double clic qui est très grande même trop grande puisque elle ne s'exécute pas même si la rédaction est correct.

je vous en mets une partie pour que vous compreniez.

Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Worksheets("Feuil1").Activate

Dim img As Object
For Each img In Worksheets("Feuil1").Shapes
If img.Name <> "SEARCH" And img.Name <> "logo" And img.Name <> "Connecteur droit avec flèche 7" And img.Name <> "Connecteur droit avec flèche 31" And img.Type <> 8 Then img.Delete
Next
Range("D13:Z600").ClearContents
Range("D13:Z600").ClearFormats
'Range("D13:Z600").Interior.Color = RGB(255, 255, 255)
Cancel = True

Dim label As String
Dim credit As String
Dim w As Worksheet
Set w = Worksheets("LEED")

credit = Range("B9")

If Target = "Aesthetic exterior concrete surfaces - Artevia" Then
w.Range("A1:C1").Copy Destination:=Range("E13")
w.Range("R2:S18").Copy Destination:=Range("F14")
w.Shapes("Image 13").Copy
Range("G15").Select
Paste
Select Case credit
    Case Is = "SS Credit 7.1 : Heat Island Effect - Nonroof (1 point)"
    w.Range("A2:A18").Copy Destination:=Range("E14")
    Case Is = "MR Credit 4 : Recycled Content (1-2 points)"
    w.Range("b2:b18").Copy Destination:=Range("E14")
    Case Is = "MR Credit 5 : Regional Materials (1-2 points)"
    w.Range("c2:c18").Copy Destination:=Range("E14")
    Case Is = "Man 3 : Construction Site Impacts"
    w.Range("d2:d18").Copy Destination:=Range("E14")
    Case Is = "Mat 1 : Materials Specification (Major Building Elements)"
    w.Range("e2:e18").Copy Destination:=Range("E14")
    Case Is = "Mat 2 : Hard Landscaping and Boundary Protection"
    w.Range("f2:f18").Copy Destination:=Range("E14")
    Case Is = "Mat 5 : Responsible Sourcing of Materials"
    w.Range("g2:g18").Copy Destination:=Range("E14")
    Case Is = "Wst 2 : Recycled Aggregates"
    w.Range("h2:h18").Copy Destination:=Range("E14")
    End Select

ElseIf Target = "Aesthetic finish concrete wall - Agilia" Then
w.Range("A20:C20").Copy Destination:=Range("E13")
w.Range("R21:S37").Copy Destination:=Range("F14")
w.Shapes("Image 14").Copy
Range("G15").Select
Paste
Select Case credit
    Case Is = "MR Credit 2 : Construction Waste Management (1-2 points)"
    w.Range("A21:A37").Copy Destination:=Range("E14")
    Case Is = "MR Credit 4 : Recycled Content (1-2 points)"
    w.Range("b21:b37").Copy Destination:=Range("E14")
    Case Is = "MR Credit 5 : Regional Materials (1-2 points)"
    w.Range("c21:c37").Copy Destination:=Range("E14")
    Case Is = "IEQ Credit 4.2 : Low-Emitting Materials & Paints and Coatings (1 point)"
    w.Range("d21:d37").Copy Destination:=Range("E14")
    Case Is = "IEQ Credit 7.1 : Thermal Comfort - Design (1 point)"
    w.Range("e21:e37").Copy Destination:=Range("E14")
    Case Is = "Man 3 : Construction Site Impacts"
    w.Range("f21:f37").Copy Destination:=Range("E14")
    Case Is = "Hea 10 : Thermal Comfort"
    w.Range("g21:g37").Copy Destination:=Range("E14")
    Case Is = "Mat 1 : Materials Specification (Major Building Elements)"
    w.Range("h21:h37").Copy Destination:=Range("E14")
    Case Is = "Mat 5 : Responsible Sourcing of Materials"
    w.Range("i21:i37").Copy Destination:=Range("E14")
    Case Is = "Wst 2 : Recycled Aggregates"
    w.Range("j21:j37").Copy Destination:=Range("E14")
    End Select

à chaque else if j'ai un bloc de code que je ne peux pas rassembler avec un autre puisque les conditions sont différentes et le résultat aussi.

En fait le but est de selectionner des options à l'aide de 2 menus déroulants et en fonctions de ces deux options on copie et colle sur la feuille le tableau correspondant

je dois avoir une bonne soixantaine de blocs comme ça....

donc ma question est la suivante comment faire appelle à des sous fonctions pour diminuer la taille de la procédure afin qu'elle ne soit pas trop grande ?

Help please !!!

Merci d'avance pour votre aide

Au lieu de faire un select case en mode gros baroudeur des steppes mongoles...

Fais un tableau a deux dimension, la première tu mets tes données et la deuxieme le range, il suffira de boucler sur ton tableau ou de faire un find.

3000 lignes remplacées par 3.

tu peux me faire un petit exemple stp

Voilà pour ton premier if... il te suffit d'ajuster pour ton select case dans le même esprit

tabdata = Array("Aesthetic exterior concrete surfaces - Artevia", "Aesthetic finish concrete wall - Agilia")
tabrange = Array("A1:C1", "R2:S18", "A20:C20", "R21:S37")
tabrange2 = Array("SS Credit 7.1 : Heat Island Effect - Nonroof (1 point)", "MR Credit 4 : Recycled Content (1-2 points)", "MR Credit 5 : Regional Materials (1-2 points)")

For i = LBound(tabdata) To UBound(tabdata)
If tabdata(i) = target Then
w.Range(tabrange(i*2)).Copy Destination:=Range("E13")
w.Range(tabrange(i*2+1)).Copy Destination:=Range("F14")
w.Shapes("Image " & i + 13).Copy
Range("G15").Select
End If
Next i

merci beaucoup je vais me débrouiller avec ça

No problemo. Bon courage, il y a du boulot de copier collers!