XL 2016 Grouper 3 macros

luke3300

luke3300

XLDnaute Impliqué
Bonjour le forum,

J'utilise 3 macros actuellement et j'aimerais les simplifier et n'en avoir qu'une seule.

Voici les codes:

Code: 
Sub Macro2()
'
' Copie les noms
'

'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Sheets("New").Select
    Range("A5").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Distribution").Select
    Range("D26").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False 'supprime le clignotement lié au copier/coller
    Range("F26").Select
    Sheets("Données").Select
    Range("A1").Select
End Sub
Sub Macro3()
'
' Macro3 Macro
'

'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Sheets("New").Select
    Range("D2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets("Distribution").Select
    Range("F9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.Replace What:="J0", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="JS", Replacement:="S", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Application.CutCopyMode = False 'supprime le clignotement lié au copier/coller
    Range("F26").Select
    Sheets("Données").Select
    Range("A1").Select
End Sub
Sub Macro5()
'
' Macro5 Macro
'

'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Sheets("New").Select
    Range("D5").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Distribution").Select
    Range("F26").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.Replace What:="2", Replacement:="1", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="3", Replacement:="1", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Application.CutCopyMode = False 'supprime le clignotement lié au copier/coller
    Range("F26").Select
    Sheets("Données").Select
    Range("A1").Select
End Sub

Il s'agit de Macros de copier/coller et de remplacement de valeurs.

Merci d'avance pour l'aide que vous pourrez m'apporter et excellent début de semaine à toutes et tous.
 
Trier par date Trier par votes
cp4

cp4

XLDnaute Barbatruc
Voilààààààààà, c'est plus clair.
Mais comme les références de tes plages de données entre la feuille new et distribution sont différentes.
Je reverrai ça ce soir ou demain.

edit: ça a été plus facile que je ne le pensais.
VB: 
Option Explicit

Sub essai1()
   Dim Lfs As Integer, Lfd As Integer, Cfs As Integer, Cfd As Integer
   Dim NbCfd As Integer
   Dim Fs As Worksheet, Fd As Worksheet
   Set Fs = Worksheets("new")
   Set Fd = Worksheets("distribution")

   With Fd
      Lfd = .Range("d" & Rows.Count).End(xlUp).Row
      Cfd = .Range("f9").End(xlToRight).Column
      NbCfd = Cfd - 5
      .Range("D26:D" & Lfd).ClearContents
      On Error Resume Next
      .Range(Cells(9, 6), Cells(9, 6 + NbCfd)).ClearContents
      On Error GoTo 0

   End With

   With Fs
      Lfs = .Range("a" & Rows.Count).End(xlUp).Row
      Cfs = .Range("D2").End(xlToRight).Column
      .Range("A5:A" & Lfs).Copy Fd.Range("D26")
      .Range(.Cells(2, 4), .Cells(2, Cfs)).Copy
      Fd.Range("F9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      .Range(.Cells(5, 4), .Cells(Lfs, Cfs)).Copy
      Fd.Range("F26").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
   End With

   With Fd
      Dim cel As Range
      Lfd = .Range("d" & Rows.Count).End(xlUp).Row
      Cfd = .Range("f9").End(xlToRight).Column
      For Each cel In .Range(.Cells(9, 4), .Cells(9, Cfd))
         cel = Replace(cel, "J0", "")
         cel = Replace(cel, "JS", "S")
      Next
      For Each cel In .Range(.Cells(26, 5), .Cells(Lfd, Cfd))
         cel = Replace(cel, 2, 1)
         cel = Replace(cel, 3, 1)
      Next
   End With
End Sub
En espérant que c'est bon.
 
Dernière édition:
Vote positif 0 Vote négatif
luke3300

luke3300

XLDnaute Impliqué
Bonjour cp4, le forum et d'ores et déjà une très belle année 2019 à tous :)

Je me suis penché cette semaine sur le code du post #16 qui fonctionne à merveille :D (merci encore cp4, remarquable travail ;)).

J'ai adapté un peu dans la partie "With Fs" pour le format qui se collait et dans "With Fd", j'ai remplacé le 5 de "Range(.Cells(26, 5)" par un 6 comme ça la macro ne remplaçait pas les formules de la colonne par un nombre ou un 0.

Code: 
Sub Essai_1()
   Dim Lfs As Integer, Lfd As Integer, Cfs As Integer, Cfd As Integer
   Dim NbCfd As Integer
   Dim Fs As Worksheet, Fd As Worksheet
   Set Fs = Worksheets("new")
   Set Fd = Worksheets("distribution")

   With Fd
      Lfd = .Range("d" & Rows.Count).End(xlUp).Row
      Cfd = .Range("f9").End(xlToRight).Column
      NbCfd = Cfd - 5
      .Range("D26:D" & Lfd).ClearContents
      On Error Resume Next
      .Range(Cells(9, 6), Cells(9, 6 + NbCfd)).ClearContents
      On Error GoTo 0

   End With

   With Fs
      Lfs = .Range("a" & Rows.Count).End(xlUp).Row
      Cfs = .Range("D2").End(xlToRight).Column
      .Range("A5:A" & Lfs).Copy
      Fd.Range("D26").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      .Range(.Cells(2, 4), .Cells(2, Cfs)).Copy
      Fd.Range("F9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      .Range(.Cells(5, 4), .Cells(Lfs, Cfs)).Copy
      Fd.Range("F26").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
   End With

   With Fd
      Dim cel As Range
      Lfd = .Range("d" & Rows.Count).End(xlUp).Row
      Cfd = .Range("f9").End(xlToRight).Column
      For Each cel In .Range(.Cells(9, 4), .Cells(9, Cfd))
         cel = Replace(cel, "J0", "")
         cel = Replace(cel, "JS", "S")
      Next
      For Each cel In .Range(.Cells(26, 6), .Cells(Lfd, Cfd))
         cel = Replace(cel, 2, 1)
         cel = Replace(cel, 3, 1)
      Next
   End With

End Sub

J'aimerais cependant masquer le travail de la macro pour que cela se passe soit discret mais je ne sais pas où placer la commande suivante:

Application.ScreenUpdating = False
Application.DisplayAlerts = False

ni comment accélérer quelques peu celle-ci ... si toutefois c'est possible?

Encore merci pour votre aide et excellente journée à tous.
 
Vote positif 0 Vote négatif
cp4

cp4

XLDnaute Barbatruc
Bonjour et bonne année,

Tu les mets juste avant le 1er With Fd
VB: 
Option Explicit

Sub Essai_1()
   Dim Lfs As Integer, Lfd As Integer, Cfs As Integer, Cfd As Integer
   Dim NbCfd As Integer
   Dim Fs As Worksheet, Fd As Worksheet
   Set Fs = Worksheets("new")
   Set Fd = Worksheets("distribution")
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   With Fd
      Lfd = .Range("d" & Rows.Count).End(xlUp).Row
      Cfd = .Range("f9").End(xlToRight).Column
      NbCfd = Cfd - 5
      .Range("D26:D" & Lfd).ClearContents
      On Error Resume Next
      .Range(Cells(9, 6), Cells(9, 6 + NbCfd)).ClearContents
      On Error GoTo 0

   End With

   With Fs
      Lfs = .Range("a" & Rows.Count).End(xlUp).Row
      Cfs = .Range("D2").End(xlToRight).Column
      .Range("A5:A" & Lfs).Copy
      Fd.Range("D26").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      .Range(.Cells(2, 4), .Cells(2, Cfs)).Copy
      Fd.Range("F9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      .Range(.Cells(5, 4), .Cells(Lfs, Cfs)).Copy
      Fd.Range("F26").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
   End With

   With Fd
      Dim cel As Range
      Lfd = .Range("d" & Rows.Count).End(xlUp).Row
      Cfd = .Range("f9").End(xlToRight).Column
      For Each cel In .Range(.Cells(9, 4), .Cells(9, Cfd))
         cel = Replace(cel, "J0", "")
         cel = Replace(cel, "JS", "S")
      Next
      For Each cel In .Range(.Cells(26, 6), .Cells(Lfd, Cfd))
         cel = Replace(cel, 2, 1)
         cel = Replace(cel, 3, 1)
      Next
   End With
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
cp4

cp4

XLDnaute Barbatruc
une autre approche utilisant des tableaux
VB: 
Option Explicit

Sub Essai_()
   Dim Lfs As Integer, Lfd As Integer, Cfs As Integer, Cfd As Integer
   Dim NbCfd As Integer, tbA, tbB, tbC, i As Integer, j As Integer, k As Integer
   Dim Fs As Worksheet, Fd As Worksheet
   Set Fs = Worksheets("new")
   Set Fd = Worksheets("distribution")
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False

   With Fd 'vider les données
      Lfd = .Range("d" & Rows.Count).End(xlUp).Row
      Cfd = .Range("f9").End(xlToRight).Column
      NbCfd = Cfd - 5
      .Range("D26:D" & Lfd).ClearContents
      On Error Resume Next
      .Range(Cells(9, 6), Cells(9, 6 + NbCfd)).ClearContents
      On Error GoTo 0
   End With

   With Fs 'traitement par Array
      Lfs = .Range("a" & Rows.Count).End(xlUp).Row
      Cfs = .Range("D2").End(xlToRight).Column
      tbA = .Range("A5:A" & Lfs).Value
      tbB = .Range(.Cells(2, 4), .Cells(2, Cfs)).Value
      tbC = .Range(.Cells(5, 4), .Cells(Lfs, Cfs)).Value

      For i = LBound(tbB) To UBound(tbB, 2)
         tbB(1, i) = Replace(tbB(1, i), "J0", "")
         tbB(1, i) = Replace(tbB(1, i), "JS", "S")
      Next i

      For j = 1 To UBound(tbC, 1)
         For k = 1 To UBound(tbC, 2)
            tbC(j, k) = Replace(tbC(j, k), 2, 1)
            tbC(j, k) = Replace(tbC(j, k), 3, 1)
         Next k
      Next j
   End With
  
   With Fd 'restitution données
      Dim cel As Range
      Lfd = .Range("d" & Rows.Count).End(xlUp).Row
      Cfd = .Range("f9").End(xlToRight).Column
      .Range("D26").Resize(UBound(tbA, 1)) = tbA
      .Range("F9").Resize(LBound(tbB, 2), UBound(tbB, 2)) = tbB
      .Range("F26").Resize(UBound(tbC, 1), UBound(tbC, 2)) = tbC
   End With
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

S
  • Question
XL 2016 Inversion jour / mois
Réponses
2
Affichages
178
dysorthographie
dysorthographie
R
  • Résolu(e)
XL 2019 creer une macro pour copier des info d un onglet a un autre dans le meme classeur
Réponses
4
Affichages
281
robpellan52
R
D
  • Question
Microsoft 365 Problème avec remplacer . par ,
Réponses
3
Affichages
281
de_hanstrapp
D
G
  • Résolu(e)
XL 2013 copier coller valeur d'une colonne dynamique
Réponses
13
Affichages
344
gwenn49
G
F
  • Question
Microsoft 365 Poursuivre ou pas la macro
Réponses
2
Affichages
199
Francky79
F
T
  • Question
Microsoft 365 Modification formules via VBA
Réponses
1
Affichages
127
Dudu2
Dudu2
N
  • Résolu(e)
XL 2019 transformation de cordonnée GPS
Réponses
14
Affichages
852
sylvanu
sylvanu
O
  • Question
XL 2010 aide sur code VBA collationnement de données
Réponses
10
Affichages
461
olivier388
O
S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
1 K
AtTheOne
AtTheOne
B
  • Question
Microsoft 365 Remplacer "." par "," avec VBA sans qu'il considère que c'est des milliers si ça ne commence par "0."
Réponses
1
Affichages
301
Eric KERGRESSE
E

Membres actuellement en ligne

14 membres et 132 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 345
Messages
2 087 490
Membres
103 558
dernier inscrit
Lamine ABIDI