Modifications de ma macro

Bonjour à tous,

Dans mon classeur nommé adresses, j'ai une macro commandée par le bouton valider qui envoies mes données encodées dans la feuille encodage vers la feuille A. j'aimerais si cela est possible, au lieu de créer une macro pour chaque feuille, c'est à dire A-B-C-D et les autres lettres de l'alphabet et en fonction de la lettre affichée en B8 de la feuille encodage la macro copie le contenu vers la feuille correspondante. Que faut-il changer dans ma macro et si cela est possible???

D'avance merci

Eugène

Bonjour,

Un essai ...

Sub Vers_A() 'Changer de nom de la  feuille
Dim NomF As String  ' nom de la feuille

    Application.ScreenUpdating = False

    NomF = ActiveSheet.Range("B8").Value

    Sheets(NomF).Activate 'Changer de nom de la  feuille

    Range("A4").Offset(0, 0).Resize(7, 1).EntireRow.Insert

    Range("A4:E10").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlHairline
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("A4").Select
    Sheets("Encodage").Activate
    Range("C8:G14").Copy
    Sheets(NomF).Activate 'Changer de nom de la  feuille
    Range("A4").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    'Range("A4").Select
    'With Selection
        '.HorizontalAlignment = xlLeft
        '.VerticalAlignment = xlCenter
        '.WrapText = False
        '.Orientation = 0
        '.AddIndent = False
        '.IndentLevel = 0
        '.ShrinkToFit = False
        '.ReadingOrder = xlContext
        '.MergeCells = False
   'End With
    'With Selection.Font
     '.FontStyle = "Gras"
    'End With
    For i = 4 To Cells(Rows.Count, "A").End(xlUp).Row Step 7 ' A partir de la ligne 4 pour 7 lignes au total
    For j = i To Cells(Rows.Count, "A").End(xlUp).Row Step 7
        If Cells(i, "A") > Cells(j, "A") Then ' Changer du plus petit au plus grand >
            Rows(j & ":" & j + 6).Cut ' la première ligne +6
            Rows(i).Insert Shift:=xlDown
        End If
    Next
Next
    Range("A3").Select
    Sheets("Encodage").Activate
    Range("C8,E8:E14,G8:G14").ClearContents
    Range("C8").FormulaR1C1 = "Noms"
    Range("E8").NumberFormat = """Mobile ""0032"" ""000"" ""00"" ""00"" ""00"
    Range("E13").NumberFormat = """BE""00"" ""0000"" ""0000"" ""0000"
    Range("G8").NumberFormat = """Fixe ""0032"" ""0"" ""000"" ""00"" ""00"
    Range("C8").Select
    ActiveWorkbook.Save
    Application.ScreenUpdating = True
End Sub

ric

Grand merci Ric

Cela fonctionne parfaitement

Eugène

Bonjour,

Si tu as remarqué, j'ai enlevé plusieurs ".Select".

Il faut tenter de les utiliser le moins possible, ils ralentissent considérablement l'exécution du code.

ric

Bonjour Eugène, Ric, bonjour le forum,

La règle d'or en VBA c'est d'éviter autant que tu le peux les Select et autres Activate inutiles.

Ton code modifié (si j'ai bien compris) :

Sub Vers_A() 'Changer de nom de la  feuille
Dim OE As Worksheet 'déclare la variable OE (Onglet Encodage)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)

Application.ScreenUpdating = False
Set OE = Worksheets("Encodage")
Set OD = Worksheets(OE.Range("B8").Value)
OD.Range("A4").Offset(0, 0).Resize(7, 1).EntireRow.Insert
With OD.Range("A4:E10")
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlHairline
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
OE.Range("C8:G14").Copy
OD.Range("A4").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
   xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
    'Range("A4").Select
    'With Selection
        '.HorizontalAlignment = xlLeft
        '.VerticalAlignment = xlCenter
        '.WrapText = False
        '.Orientation = 0
        '.AddIndent = False
        '.IndentLevel = 0
        '.ShrinkToFit = False
        '.ReadingOrder = xlContext
        '.MergeCells = False
   'End With
    'With Selection.Font
     '.FontStyle = "Gras"
    'End With
For I = 4 To OD.Cells(Rows.Count, "A").End(xlUp).Row Step 7 ' A partir de la ligne 4 pour 7 lignes au total
    For j = I To OD.Cells(Rows.Count, "A").End(xlUp).Row Step 7
        If OD.Cells(I, "A") > OD.Cells(j, "A") Then ' Changer du plus petit au plus grand >
            OD.Rows(j & ":" & j + 6).Cut ' la première ligne +6
            OD.Rows(I).Insert Shift:=xlDown
        End If
    Next
Next I
OD.Range("C8,E8:E14,G8:G14").Selection.ClearContents
OD.Range("C8").FormulaR1C1 = "Noms"
OD.Range("E8").NumberFormat = """Mobile ""0032"" ""000"" ""00"" ""00"" ""00"
OD.Range("E13").NumberFormat = """BE""00"" ""0000"" ""0000"" ""0000"
OD.Range("G8").NumberFormat = """Fixe ""0032"" ""0"" ""000"" ""00"" ""00"
OD.Activate
OD.Range("C8").Select
ActiveWorkbook.Save
Application.ScreenUpdating = True
End Sub