Microsoft 365 Durée d'exécution des macros différentes suivants le type de lancement

DanB34

XLDnaute Nouveau
Bonjour,
Lorsque je lance une série de macros depuis l'éditeur de macros, celles-ci prennent environ 1 à 2 secondes. Lorsque je lance les mêmes macros depuis le bouton affiché sur la feuille, la durée est multipliée par 5.
Je soupçonne un problème d’affichage, peut-être de focus sur la feuille, car le pointeur de la souris se transforme en rond avec une croix dedans.
Si quelqu'un a déjà connu ce genre de problème...
Merci d'avance pour vos idées.
Bien cordialement
Dan
 
Solution
Re, Bonsoir eriiiic

Une autre pour la route
(A vérifier qu'elle fait bien la même chose que l'originale)
VB:
Sub Supprimer_Colonnes_G()
Sheets("Contacts").Columns("D:D").Cut Columns("A:A")
' Suppression des colonnes inutiles
Range("B:B:AH:AH").EntireColumn.Delete
End Sub

DanB34

XLDnaute Nouveau
Bonsoir,
C'est un fichier d'adresse, je ne peux donc joindre que les macros, mais je doute qu'elles puissent apporter quelque chose sans la feuille à traiter qui elles est composée de 500 lignes et de 77 colonnes !
Je joins tout de même le code, au cas où.
Tout passe par la procédure en début de code "Lance_Macros"
Merci d'avance pour l'aide.
Dan
VB:
Option Explicit
Option Base 1

Sub Lance_Macros()
If MsgBox("Voulez-vous importer une mise à jour de vos adresses ?", vbYesNo + vbQuestion, _
"Demande de confirmation") = vbYes Then
    Call Copie_Donnees
Application.ScreenUpdating = False
    Call Supprimer_Colonnes_G
    Call Renommage_Colonnes_G
    Call Formatage
    Call Tri_Nom_Prenom
    Call Rassemble_Mails
    Call Rassemble_Telephones
Application.ScreenUpdating = True
    Call Mise_en_Forme
Else
    MsgBox "Importation annulée", vbOKOnly + vbInformation, "Aucune modification effectuée"
    Exit Sub
End If
End Sub


Sub Filtres_On_Off()
' Filtre sur les noms situés sur l'onglet "Liste" (ou retire le filtre s'il est actif)
Dim Tablo() As Variant
Dim NomTableau As String
Dim NbContact As Integer
Dim i As Integer
Dim DerLigne As Integer

Application.ScreenUpdating = False
If Worksheets("Contacts").FilterMode Then
        Worksheets("Contacts").ShowAllData
        Worksheets("Contacts").Shapes("Button 5").Visible = False
        Worksheets("Contacts").Shapes("Button 1").Visible = True
Else
    DerLigne = Worksheets("Liste").Range("A65000").End(xlUp).Row
' Redimension automatique du tableau en fonction du nombre de lignes occupées
    ReDim Tablo(2 To DerLigne)
    For i = LBound(Tablo) To UBound(Tablo)
        Tablo(i) = Sheets("Liste").Cells(i, "A").Value
    Next i
    NomTableau = Worksheets("Contacts").ListObjects(1).Name
    Worksheets("Contacts").ListObjects(NomTableau).Range.AutoFilter Field:=1, Criteria1:= _
        Array(Tablo), Operator:=xlFilterValues
        Worksheets("Contacts").Shapes("Button 1").Visible = False
        Worksheets("Contacts").Shapes("Button 5").Visible = True
End If

Call Masque_lignes_condition_cellule

Application.Goto Range("A2"), Scroll:=True

' Affichage du nombre d'enregistrements filtrés ou total
NbContact = Application.Subtotal(3, Columns("A")) - 1
Application.ScreenUpdating = True
MsgBox NbContact & " contacts affichés", vbOKOnly + vbInformation, "Information"
End Sub


Sub Masque_lignes_condition_cellule()
' Masque des lignes dans le cas ou l'on ne veut pas afficher certaines personnes qui auraient le même nom de famille (ex. Xxxxx Nicole)
' Recherche sur Nom et Prénom des colonnes F et G de la feuille Liste
Dim lg As Long, r As Long
Dim Tablo() As Variant
Dim i, j As Integer
Dim DerLigM As Integer

With ActiveSheet.UsedRange
    lg = .Row + .Rows.Count - 1
End With

DerLigM = Sheets("Liste").Range("F65000").End(xlUp).Row

Dim Tab_Masquer()
ReDim Tab_Masquer(DerLigM - 1, 2)
For i = 1 To DerLigM - 1
    Tab_Masquer(i, 1) = Sheets("Liste").Range("F" & i + 1)
    Tab_Masquer(i, 2) = Sheets("Liste").Range("G" & i + 1)
    For r = lg To 1 Step -1
        If Cells(r, "A") Like Tab_Masquer(i, 1) And Cells(r, "B") Like Tab_Masquer(i, 2) Then
            Rows(r).EntireRow.Hidden = True
        End If
    Next r
Next
End Sub


Sub Supprimer_Liaison()
Dim NomTableau As String

    NomTableau = Worksheets("Contacts").ListObjects(1).Name
    'Supprimer le lien du tableau
    ActiveSheet.ListObjects(NomTableau).Unlink
End Sub


Sub Supprimer_Colonnes_G()
' Suppression des colonnes inutiles
Dim FE, FC, FL As Sheets

Set FE = Worksheets("Export")
Set FC = Worksheets("Contacts")

' Déplacement de la colonne des noms située col. D en col. A
    FC.Select
    FC.Columns("D:D").Cut
    Columns("A:A").Insert shift:=xlToRight
    'Columns("A:A").Select
    'Selection.Insert shift:=xlToRight
 
' Suppression des colonnes inutiles
    Columns("B:B").Delete shift:=xlToLeft
    Columns("C:M").Delete shift:=xlToLeft
    Columns("D:M").Delete shift:=xlToLeft
    Columns("E:H").Delete shift:=xlToLeft
    Columns("F:F").Delete shift:=xlToLeft
    Columns("G:G").Delete shift:=xlToLeft
    Columns("H:L").Delete shift:=xlToLeft
    Columns("I:I").Delete shift:=xlToLeft
    Columns("J:J").Delete shift:=xlToLeft
    Columns("K:P").Delete shift:=xlToLeft
    Columns("M:N").Delete shift:=xlToLeft
    Columns("N:AH").Delete shift:=xlToLeft

End Sub


Sub Renommage_Colonnes_G()
' Renommage_Colonnes Macro
'
Dim NomTableau As String


    NomTableau = Worksheets("Contacts").ListObjects(1).Name
    
    Sheets("Contacts").Select
    
    Range("A1") = "Nom"
    Range("B1") = "Prénom"
    Range("C1") = "D.Nais."
    Range("E1") = "E-Mail"
    Range("F1") = "E-Mail2"
    Range("G1") = "E-Mail3"
    Range("H1") = "Mobile"
    Range("I1") = "Tél. Domicile"
    Range("J1") = "Tél. Travail"
    Range("K1") = "Adresse"
    Range("L1") = "Ville"
    Range("M1") = "C.Postal"
        

'Range("C2").Select
End Sub


Sub Selection_Donnees()

Dim CelDeb As String
Dim CelFin As String

CelDeb = Range("A1").Address
CelFin = Range("A1").SpecialCells(xlCellTypeLastCell).Address

' Sélection et copie de toutes les cellules occupées de la feuille
Range(CelDeb & ":" & CelFin).Select
    
End Sub


Sub Copie_Donnees()
Dim NomFeuil As String
Dim nbOnglets As Integer
Dim k As Integer, i As Integer
Dim CelDeb As String
Dim CelFin As String

' Nommage de la feuille Export
k = Sheets.Count
If k > 4 Then
    For i = 1 To k
        'Sheets(i).Activate
        NomFeuil = Sheets(i).Name
    'If ActiveSheet.Name <> "Export" Or ActiveSheet.Name <> "Explications" Or ActiveSheet.Name <> "Contacts" Then
        If NomFeuil <> "Liste" And NomFeuil <> "Explications Export Outlook" And NomFeuil <> "Explications Export Google" And NomFeuil <> "Contacts" Then
            Sheets(i).Select
            ActiveSheet.Name = "Export"
            'Exit Sub
        End If
    Next i
'    Sheets("Export").Select
Else
    MsgBox "Les données n'ont pas encore été importées." & vbCrLf & _
    "Avant de poursuivre vous devez avoir effectué l'import." & vbCrLf & _
    "(une nouvelle feuille sera visible).", vbOKOnly + vbInformation, "Informations"
    End
End If

' Supprime les données de la feuille de travail "Listing_Adresses"
Worksheets("Export").Select
CelDeb = Worksheets("Contacts").Range("A1").Address
CelFin = Worksheets("Contacts").Range("A1").SpecialCells(xlCellTypeLastCell).Address
Worksheets("Contacts").Range(CelDeb & ":" & CelFin).ClearContents

CelDeb = Worksheets("Export").Range("A1").Address
CelFin = Worksheets("Export").Range("A1").SpecialCells(xlCellTypeLastCell).Address

'Copie de toutes les cellules occupées de la feuille "Export" sur la feuille "Contacts"
Worksheets("Export").Range(CelDeb & ":" & CelFin).Copy (Worksheets("Contacts").Range("A1"))

End Sub


Sub Formatage()
' Mise en forme du tableau
Dim NomTableau As String
Dim DerLigne As Integer

' Déplacement de la colonne D en fin de tableau
    DerLigne = Range("D65000").End(xlUp).Row
    Range("D1:D" & DerLigne).Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("N1").Select
    ActiveSheet.Paste
    Columns("D:D").Delete shift:=xlToLeft
    Range("M1") = "Notes"
      
' Récupération du nom du tableau dans la variable NomTableau (change à chaque fois)
    NomTableau = Worksheets("Contacts").ListObjects(1).Name
' Tri sur Nom et Prénom
    ActiveWorkbook.Worksheets("Contacts").ListObjects(NomTableau).Sort. _
        SortFields.Clear
    ActiveWorkbook.Worksheets("Contacts").ListObjects(NomTableau).Sort. _
        SortFields.Add2 Key:=Range(NomTableau & "[Nom]"), SortOn:=xlSortOnValues, _
        Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Contacts").ListObjects(NomTableau).Sort. _
        SortFields.Add2 Key:=Range(NomTableau & "[Prénom]"), SortOn:= _
        xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Contacts").ListObjects(NomTableau).Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
      
' Suppression de la liaison avec la bd
    NomTableau = Worksheets("Contacts").ListObjects(1).Name
    ActiveSheet.ListObjects(NomTableau).Unlink
      
    Call Supprimer_Retour_Ligne

End Sub


Sub Tri_Nom_Prenom()
' Tri_Nom_Prenom Macro
Dim NomTableau As String
Dim NbContact As Integer

' Récupération du nom du tableau dans la variable NomTableau (change à chaque fois)
    NomTableau = Worksheets("Contacts").ListObjects(1).Name
    ActiveWorkbook.Worksheets("Contacts").ListObjects(NomTableau).Sort. _
        SortFields.Clear
    ActiveWorkbook.Worksheets("Contacts").ListObjects(NomTableau).Sort. _
        SortFields.Add2 Key:=Range(NomTableau & "[Nom]"), SortOn:=xlSortOnValues, _
        Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Contacts").ListObjects(NomTableau).Sort. _
        SortFields.Add2 Key:=Range(NomTableau & "[Prénom]"), SortOn:=xlSortOnValues _
        , Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Contacts").ListObjects(NomTableau).Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub


Sub Supprimer_Retour_Ligne()
'Supprime les retours à la ligne colonne M
Dim DerLigne As Integer
Dim i As Integer
Dim Cpt As Integer

DerLigne = Range("A65000").End(xlUp).Row
Cpt = 0
On Error Resume Next
'For Cpt = 1 To 5
For i = 1 To DerLigne
    For Cpt = 1 To 3
        Range("M" & i).Select
        Selection.Replace What:=Chr(10) & Chr(10), Replacement:=Chr(10)
        If Right(Selection, 1) = Chr(10) Then Selection = Left(Selection, Len(Selection) - 1)
    Next Cpt
Next i

' Resserage des lignes en fonction du contenu
    Rows("2:" & DerLigne).EntireRow.AutoFit
End Sub


Sub Mise_en_Forme()
'Met en forme le fichier
Dim NbContact, DerLigne As Integer

Application.ScreenUpdating = False
    DerLigne = Range("A65000").End(xlUp).Row
' Dimensionnement de la largeur des colonnes
    Columns("A:B").ColumnWidth = 20
    Columns("C:C").Select
    With Selection
        .ColumnWidth = 12
        .HorizontalAlignment = xlCenter
    End With
    Columns("D:D").ColumnWidth = 45
    Columns("D:D").Select
    With Selection
        .HorizontalAlignment = xlLeft
    End With
    Columns("E:E").Select
    With Selection
        .ColumnWidth = 18
        .HorizontalAlignment = xlCenter
    End With
    Columns("F:F").ColumnWidth = 35
    Columns("G:G").ColumnWidth = 18
    Columns("H:H").Select
    With Selection
        .ColumnWidth = 12
        .HorizontalAlignment = xlCenter
    End With
    Columns("I:I").ColumnWidth = 75
    Columns("J:J").ColumnWidth = 2
    
' Formatage colonne I (retour à la ligne)
    Columns("F:F").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
' Formatage colonne I (retour à la ligne)
    Columns("I:I").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
      
' Formatage centrage des données en vertical
    Rows("2:" & DerLigne).Select
    With Selection
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
 'Affichage en pleine largeur d'écran
    Application.CommandBars("Queries and Connections").Visible = False
    Range("A1:J1").Select
    ActiveWindow.Zoom = True
    Range("A2").Select

Application.ScreenUpdating = True
' Affichage du nombre d'enregistrements filtrés ou total
    NbContact = Application.Subtotal(3, Columns("A")) - 1
    Application.Goto Range("A2"), Scroll:=True
    MsgBox NbContact & " contacts affichés", vbOKOnly + vbInformation, "Information"
End Sub


Sub Rassemble_Mails()
Dim DerLigne As Integer
Dim i As Integer
Dim NomTableau As String
Dim Cpt As Integer
Dim MailGlobal, Mail1, Mail2, Mail3 As String
Const ColRgtMails = "D" 'Regroupement E-Mails
Const ColMail1 = "E" 'Mail1
Const ColMail2 = "F" 'E-Mail2
Const ColMail3 = "G" 'E-Mail3

DerLigne = Range("A65000").End(xlUp).Row
Columns(ColRgtMails & ":" & ColRgtMails).Select
Selection.Insert shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range(ColRgtMails & 1) = "E-Mails"
For i = 2 To DerLigne
        Mail1 = Range(ColMail1 & i).Value
        Mail2 = Range(ColMail2 & i).Value
        Mail3 = Range(ColMail3 & i).Value
    
    If Mail1 <> "" Then
        MailGlobal = Mail1
    End If
    If Mail2 <> "" Then
        MailGlobal = Mail2
    End If
    If Mail3 <> "" Then
        MailGlobal = Mail3
    End If
    If Mail1 <> "" And Mail2 <> "" Then
            MailGlobal = Mail1 & vbCrLf & Mail2
    End If
    If Mail1 <> "" And Mail3 <> "" Then
            MailGlobal = Mail1 & vbCrLf & Mail3
    End If
    If Mail2 <> "" And Mail3 <> "" Then
            MailGlobal = Mail2 & vbCrLf & Mail3
    End If
    If Mail1 <> "" And Mail2 <> "" And Mail3 <> "" Then
            MailGlobal = Mail1 & vbCrLf & Mail2 & vbCrLf & Mail3
    End If
    
    Range(ColRgtMails & i) = MailGlobal
    Mail1 = Empty
    Mail2 = Empty
    Mail3 = Empty
    MailGlobal = Empty
Next i

'Suppression des ":" parasites
    Columns(ColRgtMails & ":" & ColRgtMails).Select
    Selection.Replace What:=":", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
'Suppression des anciennes colonnes mail
    Columns(ColMail1 & ":" & ColMail3).Delete shift:=xlToLeft
End Sub


Sub Rassemble_Telephones()
Dim DerLigne As Integer
Dim i As Integer
Dim NomTableau As String
Dim Cpt As Integer
Dim TelGlobal, Tel1, Tel2, Tel3, ValTel3 As String
Const ColRgtTel = "E"
Const ColMobile = "F"
Const ColDomicile = "G"
Const ColTravail = "H"
Const ColJ = "J"
Const ColK = "K"
Const ColL = "L"

'Appel de la procédure qui formatte les n° de tél.
Call AjouteEspace

DerLigne = Range("A65000").End(xlUp).Row
NomTableau = Worksheets("Contacts").ListObjects(1).Name
    
Columns(ColRgtTel & ":" & ColRgtTel).Select
Selection.Insert shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range(ColRgtTel & 1) = "Téléphones"

For i = 2 To DerLigne
        Tel1 = Range(ColMobile & i).Value
        Tel2 = Range(ColDomicile & i).Value
        Tel3 = Range(ColTravail & i).Value
        If Tel1 <> "" Then
        TelGlobal = Tel1
    End If
    If Tel2 <> "" Then
        TelGlobal = Tel2
    End If
    If Tel3 <> "" Then
        TelGlobal = "'" & Tel3
    End If
    If Tel1 <> "" And Tel2 <> "" Then
            TelGlobal = Tel1 & vbCrLf & Tel2
    End If
    If Tel1 <> "" And Tel3 <> "" Then
            TelGlobal = Tel1 & vbCrLf & Tel3
    End If
    If Tel2 <> "" And Tel3 <> "" Then
            TelGlobal = Tel2 & vbCrLf & Tel3
    End If
    If Tel1 <> "" And Tel2 <> "" And Tel3 <> "" Then
            TelGlobal = Tel1 & vbCrLf & Tel2 & vbCrLf & Tel3
    End If

    Range(ColRgtTel & i) = TelGlobal
    Tel1 = Empty
    Tel2 = Empty
    Tel3 = Empty
    TelGlobal = Empty
Next i

'Suppression des ":" parasites
    Columns(ColRgtTel).Select
    Selection.Replace What:=":", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
'Suppression des anciennes colonnes mail
    Columns(ColMobile & ":" & ColTravail).Delete shift:=xlToLeft
End Sub


Sub AjouteEspace()
Dim AjoutEspace As String
Dim plage As Range, c As Range
Dim nbcarac As Byte
Dim DerLigne As String

DerLigne = Range("A65000").End(xlUp).Row
Set plage = Range("E2:G" & DerLigne)

'Attribue le format "Texte" à la plage des colonnes E, F, G contenant les n° de téléphones
plage.NumberFormat = "@"
    
For Each c In plage
    If c <> "" Then
        If Left(c.Value, 1) <> 0 Then
            c.Value = "0" & c.Value
        End If
        AjoutEspace = ChaineEtEspace(c.Value) '(Range("I13").Value)
        c = AjoutEspace
    End If
Next c
End Sub


Function ChaineEtEspace(xChaine)
Dim F As Integer
Dim xDeux As String
Dim xresult As String

    For F = 1 To Len(xChaine) Step 2
        xDeux = Mid(xChaine, F, 2)
        'xresult = xresult & " " & xDeux 'Pour ajouter une espace avant le 1er caractère
        xresult = xresult & xDeux & " " 'Ajoute une espace après le 2° caractère
    Next F
    'ChaineEtEspace = UCase(RTrim(xresult)) 'Met la chaine de caractères en MAJ et supprime le dernier espace
    ChaineEtEspace = RTrim(xresult) 'Supprime le dernier espace
End Function
 

Staple1600

XLDnaute Barbatruc
Re

La feuille à traiter, ce n'est pas un problème
On peut se la créer à la volée
VB:
Sub UneFeuilleExempleAnonyme()
Application.ScreenUpdating = False
Range("A1").Resize(4, 77) = "=""ITEM_""&COLUMN()"
Range("A2").Resize(499, 77) = "=ADDRESS(ROW(),COLUMN(),4)"
[A1].CurrentRegion = [A1].CurrentRegion.Value
End Sub
 

Staple1600

XLDnaute Barbatruc
Bonsoir,
Merci d'avance pour l'aide.
Dan
Dans ce cas, voici une forme d'aide
(une autre syntaxe pour une tes macros)
VB:
Sub Renommage_Colonnes_G()
'Dim NomTableau As String '-< pas utilié dans cette procédure, non ?
'NomTableau = Worksheets("Contacts").ListObjects(1).Name  '-< itou
With Sheets("Contacts").[A1:M1]
  .Value = _
  Array("Nom", "Prénom", "D.Nais.", "", "E-Mail", "E-Mail2", "E-Mail3", "Mobile", "Tél. Domicile", "Tél. Travail", "Adresse", "Ville", "C.Postal")
  .Columns.AutoFit 'falcultatif
End With
End Sub
Par contre, il faudra un peu de temps pour proposer d'autres syntaxes
Et ce soir j'ai télé ;)
Je repasserai plus tard avec d'autres propositions.
EDITION: Une deuxième procédure "simplifiée"
VB:
Sub Selection_Donnees_II()
ActiveSheet.UsedRange.Select
End Sub
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re

Pendant la pub, une autre macro "à ma sauce"
VB:
Sub Mise_en_Forme_II()
'Met en forme le fichier
Dim NbContact, DerLigne&, colP, i&
Application.ScreenUpdating = False
DerLigne = Cells(Rows.Count, 1).End(xlUp).Row
' Dimensionnement de la largeur des colonnes
colP = Array(Array("C:C", 12, xlCenter), Array("D:D", 45, xlLeft), Array("E:E", 18, xlCenter), Array("H:H", 12, xlCenter))
For i = LBound(colP) To UBound(colP)
  With Columns(colP(i)(0))
    .ColumnWidth = colP(i)(1): .HorizontalAlignment = colP(i)(2)
  End With
Next
Columns("A:B").ColumnWidth = 20: Columns("I:I").ColumnWidth = 75: Columns("G:G").ColumnWidth = 18: Columns("J:J").ColumnWidth = 2
'Formatage colonne F et I (retour à la ligne)
With Range("F:F,I:I")
.HorizontalAlignment = xlGeneral: .VerticalAlignment = xlBottom: .WrapText = True
End With
'Formatage centrage des données en vertical
Rows("2:" & DerLigne).VerticalAlignment = xlCenter
' 'Affichage en pleine largeur d'écran
'    Application.CommandBars("Queries and Connections").Visible = False
'    Range("A1:J1").Select
'    ActiveWindow.Zoom = True
'' Affichage du nombre d'enregistrements filtrés ou total
'    NbContact = Application.Subtotal(3, Columns("A")) - 1
'    Application.Goto Range("A2"), Scroll:=True
'    MsgBox NbContact & " contacts affichés", vbOKOnly + vbInformation, "Information"
End Sub
 

eriiic

XLDnaute Barbatruc
Bonjour à tous,

au passage, tu appelles un paquet de macros.
C'est bien de découper le travail, mais Application.ScreenUpdating = False est remis à True au 1er End Sub rencontré.
Tu ferais bien de le mettre au début de chaque macro, ça ne coûte pas cher.
eric
 

Staple1600

XLDnaute Barbatruc
Re, Bonsoir eriiiic

Une autre pour la route
(A vérifier qu'elle fait bien la même chose que l'originale)
VB:
Sub Supprimer_Colonnes_G()
Sheets("Contacts").Columns("D:D").Cut Columns("A:A")
' Suppression des colonnes inutiles
Range("B:B:AH:AH").EntireColumn.Delete
End Sub
 

DanB34

XLDnaute Nouveau
eriiiic : bien pris pour Application.ScreenUpdating.

Staple1600 : il y a un problème dans cette partie de macro. Je regarderai demain, car je me lève de bonne heure !!!
VB:
colP = Array(Array("C:C", 12, xlCenter), Array("D:D", 45, xlLeft), Array("E:E", 18, xlCenter), Array("H:H", 12, xlCenter))

For i = LBound(colP) To UBound(colP)

  With Columns(colP(i)(0)) -> l'indice n'appartient pas à la sélection

    .ColumnWidth = colP(i)(1): .HorizontalAlignment = colP(i)(2)

  End With

Next

Merci encore pour tout
 

Staple1600

XLDnaute Barbatruc
Re

J'ai testé sur une feuille où il n'y avait de cellules fusionnées
A vrai dire j'ai testé sur une feuille vide (puisqu'il s'agissait de formatage de colonnes)
Et lors de mon test pas de message d'erreur.
Testes sur une feuille vierge, tu verras ;)
 

DanB34

XLDnaute Nouveau
eriiiic : bien pris pour Application.ScreenUpdating.

Staple1600 : il y a un problème dans cette partie de macro. Je regarderai demain, car je me lève de bonne heure !!!
VB:
colP = Array(Array("C:C", 12, xlCenter), Array("D:D", 45, xlLeft), Array("E:E", 18, xlCenter), Array("H:H", 12, xlCenter))

For i = LBound(colP) To UBound(colP)

  With Columns(colP(i)(0)) [COLOR=rgb(226, 80, 65)]-> l'indice n'appartient pas à la sélection[/COLOR]

    .ColumnWidth = colP(i)(1): .HorizontalAlignment = colP(i)(2)

  End With

Next

Merci encore pour tout
 

DanB34

XLDnaute Nouveau
Bonjour Staple1600,
La procédure ci-dessous copie bien la colonne D de la feuille Contacts, mais l'insère sur la feuille Export (car le focus se trouve sur cette dernière).
J'ai essayé de modifier en spécifiant le nom de la feuille comme ceci Sheets("Contacts").Columns("D:D").Cut Sheets("Contacts").Columns("A:A")
puis en sélectionnant d'abord la feuille Contacts avant de lancer la procédure, mais comme le formatage est sous forme de tableau, je pense que c'est ce qui empêche la bonne exécution. J'obtiens l'erreur 1004.
VB:
Sub Supprimer_Colonnes_G()
Sheets("Contacts").Columns("D:D").Cut Columns("A:A")
' Suppression des colonnes inutiles
Range("B:B:AH:AH").EntireColumn.Delete
End Sub

Concernant la suppression des colonnes je dois préciser les colonnes suivantes
Code:
Range("B:B,D:N,P:Y,AA:AC,AJ:AM,AT:AY,BB:BC,BE:BY").EntireColumn.Select
Range("B:B,D:N,P:Y,AA:AC,AJ:AM,AT:AY,BB:BC,BE:BY").EntireColumn.Delete
La sélection des colonnes fonctionne, mais pour la suppression, j'ai aussi une erreur 1004 : La méthode Delete de la classe Range à échoué.

Je joins un fichier identique, mais rempli de données aléatoires afin de vous permettre d'avoir une idée plus précise.
Ce fichier est un export de mes contacts de Google exporté en CSV au format Google.
Il permet :
- L'import du fichier CSV
- Supprime certains champs inutiles
- Regroupe les champs mails et téléphones dans une seule colonne

Afin d'imprimer les adresses importantes :
- Filtrage afin de sélectionner une liste de personnes à afficher (par ex. les membres de la famille) -> Si le nom "Martin" est renseigné dans l'onglet "Liste" (col. A) affichera tous les "Martin" et éventuellement des "Martin" qu'on ne souhaite pas afficher dans la liste des personnes importantes
- Par un second filtrage (col. F et G) permet de ne pas afficher certains membres d'une famille, afin de ne pas afficher par ex. les enfants qui habiteraient chez les parents et réduire ainsi la liste à imprimer

Bizarrement, avec le fichier joint, le traitement est beaucoup plus rapide qu'avec mes propres données, alors qu'il y a le même nombre de données, les mêmes colonnes, pas de cellules fusionnées...

Merci encore pour l'aide apportée et pour les conseils de codage très intéressant.
Daniel
 
Dernière édition: