XL 2010 Ajout de colonne et d'onglet, la macro ne fonctionne plus

Bullosphere

XLDnaute Nouveau
Bonjour,

J'ai un soucis avec mon fichier excel. On m'a créé une macro qui me permet d'avoir une liste complète des vins non dégusté sur un onglet Statistique, mais le problème est que si j'ajoute une colonne ou un onglet cette macro ne fonctionne plus.

Je souhaiterais ajouté 2 colonnes (Région et chargé de communication) et que ses 2 colonnes soit repris dans l'onglet Statistique et ajouté l'onglet liste de choix (mais celui ci doit être ignoré par la macro). Je voudrais aussi que cette macro ne soit plus aussi restrictive, c'est à dire que je puisse ajouter ou supprimer des colonnes et des onglets à ma guise.

Autre petite chose je voudrais automatisé (par une formule) la colonne ou il y a écrit Reçu/Dégusté. Je voudrais qu'il s'affiche automatiquement Reçu lorsque j'entre une date dans la colonne Date et que cela affiche automatiquement Dégusté lorsque je mes 1 dans la colonne Dégusté.

Je joins le fichier

Merci par avance
 

Pièces jointes

  • 01-Echantillon Vin.xlsm
    199.1 KB · Affichages: 25

vgendron

XLDnaute Barbatruc
Hello

pas trop compris ce que faisait la macro
mais pour ignorer l'onglet liste de choix.. il faut l'ajouter dans le Case.... qui ne fait rien
et faire une boucle sur une colonne pour trouver le mot "Total".. il y a plus rapide
VB:
Sub SituReste()
    Dim d As Object, de As Object, k, ke, ech, trp, n%, i%, r%, Techr(), f As Worksheet
    Set d = CreateObject("Scripting.Dictionary")
    Set de = CreateObject("Scripting.Dictionary")
    For Each f In Worksheets
        Select Case f.Name
            Case "Statistique", "Liste donnée", "Liste de choix"
            Case Else
                With f
                    Set ici = .Range("C:D").Find("Total", lookat:=xlPart) 'recherche de la ligne "Total..."
                    If Not ici Is Nothing Then
                        n = ici.Row
                    End If
'                    n = .Cells(.Rows.Count, 3).End(xlUp).Row - 1
'                    Do Until .Cells(n + 1, 3) Like "Total*"
'                        n = n - 1
'                    Loop
                    For i = 2 To n
                        If .Cells(i, 3) <> "" Then
                            r = .Cells(i, 5) - .Cells(i, 6)
                            If r > 0 Then
                                k = .Cells(i, 1): ke = k & "|" & .Cells(i, 3)
                                If de.exists(ke) Then
                                    trp = de(ke)
                                    trp(1) = CInt(trp(1)) + r
                                    de(ke) = trp
                                Else
                                    trp = Array(.Cells(i, 4), r, .Cells(i, 7))
                                    d(k) = d(k) & "|" & .Cells(i, 3)
                                    de(ke) = trp
                                End If
                            End If
                        End If
                    Next i
                End With
        End Select
    Next f
    ReDim Techr(de.Count - 1, 5): n = 0
    For Each k In d.keys
        ech = Split(d(k), "|")
        Techr(n, 1) = k
        For i = 1 To UBound(ech)
            ke = k & "|" & ech(i)
            trp = de(ke)
            Techr(n, 0) = k: Techr(n, 2) = ech(i): Techr(n, 3) = trp(0)
            Techr(n, 4) = CInt(trp(1)): Techr(n, 5) = Val(Replace(trp(2), ",", "."))
            n = n + 1
        Next i
    Next k
    Application.ScreenUpdating = False
    With Worksheets("Statistique")
        .Range("A1").CurrentRegion.Offset(1).Clear
        With .Range("A2").Resize(n, 6)
            .Value = Techr
            .Borders.Weight = xlThin
            .Columns("F").NumberFormat = "# ##0.00 €"
            With .Columns("B")
                .VerticalAlignment = xlCenter
                .WrapText = True
                Application.DisplayAlerts = False
                For i = 1 To n
                    If .Cells(i, 1) <> "" Then
                        For r = i + 1 To n
                            If .Cells(r, 1) <> "" Then Exit For
                        Next r
                        With Range(.Cells(i, 1), .Cells(r - 1, 1))
                            .Merge
                        End With
                        With .Cells(i, 1).MergeArea.Resize(, 5)
                            .BorderAround xlContinuous, xlMedium
                            .Borders(xlInsideVertical).Weight = xlMedium
                        End With
                        If r > n Then Exit For Else i = r - 1
                    End If
                Next i
            End With
        End With
    End With
End Sub
 

Bullosphere

XLDnaute Nouveau
La macro prend la liste des différents vins non dégustés dans tout les onglets pour les recopier dans l'onglet statistique en comptabilisant le nombre total de chaque vin si il ce retrouve plusieurs fois sur des onglets différent
 
Dernière édition:

Bullosphere

XLDnaute Nouveau
pour cette question :
Autre petite chose je voudrais automatisé (par une formule) la colonne ou il y a écrit Reçu/Dégusté. Je voudrais qu'il s'affiche automatiquement Reçu lorsque j'entre une date dans la colonne Date et que cela affiche automatiquement Dégusté lorsque je mes 1 dans la colonne Dégusté.

Connaissez vous une formule qui permet de le faire ?
 

vgendron

XLDnaute Barbatruc
Une autre macro pour générer l"onglet statistique
si tu ajoutes des colonnes (à droite) elles seront recopiées
VB:
Sub Stat()
Dim tablo() As Variant
Application.ScreenUpdating = False

With Sheets("Statistique") 'on efface la feuille stat
    .UsedRange.Offset(1, 0).Clear
End With

For Each ws In Sheets 'pour chaque feuille du classeur
    If ws.Name <> "Statistique" And ws.Name <> "Liste donnée" And ws.Name <> "Liste de choix" Then
        With ws 'avec la feuille
            Set ici = .Range("C:D").Find("Total", lookat:=xlPart) 'recherche de la ligne "Total..."
            If Not ici Is Nothing Then
                fin = ici.Row - 2
            End If
            LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 'on cherche le nombre de colonnes
            tablo = .Range("A2").Resize(fin, LastCol).Value 'on met tout dans un tablo VBA
        End With
        For i = LBound(tablo, 1) To UBound(tablo, 1) 'pour chaque ligne du tablo
            If tablo(i, 5) - tablo(i, 6) <= 0 Then 'si il ne reste pas de bouteilles (colonnes E - Colonne F)
                For j = LBound(tablo, 2) To UBound(tablo, 2) 'on efface toute la ligne
                    tablo(i, j) = ""
                Next j
            End If
        Next i
   
    With Sheets("Statistique") 'dans la feuille stat
        fin = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'on cherche la dernière ligne pour copier les résultats
        .Range("A" & fin).Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo 'on colle le tablo en entier
    End With
    End If
Next ws

With Sheets("Statistique")
   
    Application.DisplayAlerts = False
    fin = .Range("A" & .Rows.Count).End(xlUp).Row + 1
    .Range("A1:K417").AutoFilter Field:=3, Criteria1:="=" 'on filtre sur les lignes vides en colonne C
    .Range("A2:K417").SpecialCells(xlCellTypeVisible).Delete 'on supprimeles lignes vides
    .Range("A1:K417").AutoFilter
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("B2:B" & fin).ClearContents 'on efface la colonne B
    For i = fin To 2 Step -1 'on merge 
        FinMerge = i
        DebMerge = i
        While .Range("A" & i - 1) = .Range("A" & i)
            i = i - 1
        Wend
        DebMerge = i
        .Range(.Cells(DebMerge, 1), .Cells(FinMerge, 2)).Merge
    Next i
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End With
End Sub
 

vgendron

XLDnaute Barbatruc
Une correction du code pour la mise en forme

VB:
Sub Stat()
Dim tablo() As Variant
Application.ScreenUpdating = False

With Sheets("Statistique")
    .UsedRange.Offset(1, 0).Clear
End With

For Each ws In Sheets
    If ws.Name <> "Statistique" And ws.Name <> "Liste donnée" And ws.Name <> "Liste de choix" Then
        With ws
            Set ici = .Range("C:D").Find("Total", lookat:=xlPart) 'recherche de la ligne "Total..."
            If Not ici Is Nothing Then
                fin = ici.Row - 2
            End If
            lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
            tablo = .Range("A2").Resize(fin, lastcol).Value
        End With
        For i = LBound(tablo, 1) To UBound(tablo, 1)
            If tablo(i, 5) - tablo(i, 6) <= 0 Then
                For j = LBound(tablo, 2) To UBound(tablo, 2)
                    tablo(i, j) = ""
                Next j
            End If
        Next i
   
    With Sheets("Statistique")
        fin = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & fin).Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
    End With
    End If
Next ws

With Sheets("Statistique")
   
    Application.DisplayAlerts = False
    fin = .Range("A" & .Rows.Count).End(xlUp).Row + 1
    .Range("A1").Resize(fin, lastcol).AutoFilter Field:=3, Criteria1:="="
    .Range("A2").Resize(fin, lastcol).SpecialCells(xlCellTypeVisible).Delete
    .Range("A1").Resize(fin, lastcol).AutoFilter
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("B2:B" & fin).ClearContents
    For i = fin To 2 Step -1
        FinMerge = i
        DebMerge = i
        While .Range("A" & i - 1) = .Range("A" & i)
           
            i = i - 1
        Wend
        DebMerge = i
        .Range(.Cells(DebMerge, 1), .Cells(FinMerge, 2)).Merge
    Next i
   
   
    'mise en forme
    Range("A2").Resize(fin, lastcol).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    Columns("A:K").Select
    Columns("A:K").EntireColumn.AutoFit
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End With
End Sub
 

vgendron

XLDnaute Barbatruc
et autre correction pour éviter d'avoir un même domaine sur plusieurs endroits différents
VB:
Sub Stat()
Dim tablo() As Variant
Application.ScreenUpdating = False

With Sheets("Statistique")
    .UsedRange.Offset(1, 0).Clear
End With

For Each ws In Sheets
    If ws.Name <> "Statistique" And ws.Name <> "Liste donnée" And ws.Name <> "Liste de choix" Then
        With ws
            Set ici = .Range("C:D").Find("Total", lookat:=xlPart) 'recherche de la ligne "Total..."
            If Not ici Is Nothing Then
                Fin = ici.Row - 2
            End If
            LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
            tablo = .Range("A2").Resize(Fin, LastCol).Value
        End With
        For i = LBound(tablo, 1) To UBound(tablo, 1)
            If tablo(i, 5) - tablo(i, 6) <= 0 Then
                For j = LBound(tablo, 2) To UBound(tablo, 2)
                    tablo(i, j) = ""
                Next j
            End If
        Next i
   
    With Sheets("Statistique")
        Fin = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & Fin).Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
    End With
    End If
Next ws

With Sheets("Statistique")
   
    Application.DisplayAlerts = False
    Fin = .Range("A" & .Rows.Count).End(xlUp).Row + 1
    .Range("A1").Resize(Fin, LastCol).AutoFilter Field:=3, Criteria1:="="
    .Range("A2").Resize(Fin, LastCol).SpecialCells(xlCellTypeVisible).Delete
    .Range("A1").Resize(Fin, LastCol).AutoFilter
    Fin = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("B2:B" & Fin).ClearContents
   
    'tri sur la colonne A et C pour regrouper les domaines et Type de vin
    ActiveWorkbook.Worksheets("Statistique").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Statistique").Sort.SortFields.Add Key:=Range("A2:A" & Fin), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Statistique").Sort.SortFields.Add Key:=Range("C2:C" & Fin), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Statistique").Sort
        .SetRange Range("A2").Resize(Fin, LastCol)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
    For i = Fin To 2 Step -1
        FinMerge = i
        DebMerge = i
        While .Range("A" & i - 1) = .Range("A" & i)
           
            i = i - 1
        Wend
        DebMerge = i
        .Range(.Cells(DebMerge, 1), .Cells(FinMerge, 2)).Merge
    Next i
   
   
    'mise en forme
    Range("A2").Resize(Fin, LastCol).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    Columns("A:K").Select
    Columns("A:K").EntireColumn.AutoFit
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End With
End Sub
 

vgendron

XLDnaute Barbatruc
POur éviter d'avoir à rajouter les noms de feuilles à chaque fois, voici une modif qui ne travaille que sur les feuilles dont le nom est un nombre (2017 2018...)
VB:
Sub Stat()
Dim tablo() As Variant
Application.ScreenUpdating = False

With Sheets("Statistique")
    .UsedRange.Offset(1, 0).Clear
End With

For Each ws In Sheets
    On Error Resume Next
    erreur = CInt(ws.Name)
    If erreur <> "" Then
   ' If ws.Name <> "Statistique" And ws.Name <> "Liste donnée" And ws.Name <> "Liste de choix" And ws.Name <> "Ancienne" And ws.Name <> "Nombre de bouteilles total" Then
        With ws
            Set ici = .Range("C:D").Find("Total", lookat:=xlPart) 'recherche de la ligne "Total..."
            If Not ici Is Nothing Then
                Fin = ici.Row - 2
            End If
            LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
            tablo = .Range("A2").Resize(Fin, LastCol).Value
        End With
        For i = LBound(tablo, 1) To UBound(tablo, 1)
            If tablo(i, 5) - tablo(i, 6) <= 0 Then
                For j = LBound(tablo, 2) To UBound(tablo, 2)
                    tablo(i, j) = ""
                Next j
            End If
        Next i
   
    With Sheets("Statistique")
        Fin = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & Fin).Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
    End With
    erreur = ""
    End If
Next ws

With Sheets("Statistique")
   
    Application.DisplayAlerts = False
    Fin = .Range("A" & .Rows.Count).End(xlUp).Row + 1
    .Range("A1").Resize(Fin, LastCol).AutoFilter Field:=3, Criteria1:="="
    .Range("A2").Resize(Fin, LastCol).SpecialCells(xlCellTypeVisible).Delete
    .Range("A1").Resize(Fin, LastCol).AutoFilter
    Fin = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("B2:B" & Fin).ClearContents
   
    'tri sur la colonne A et C pour regrouper les domaines et Type de vin
    ActiveWorkbook.Worksheets("Statistique").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Statistique").Sort.SortFields.Add Key:=Range("A2:A" & Fin), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Statistique").Sort.SortFields.Add Key:=Range("C2:C" & Fin), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Statistique").Sort
        .SetRange Range("A2").Resize(Fin, LastCol)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
    For i = Fin To 2 Step -1
        FinMerge = i
        DebMerge = i
        While .Range("A" & i - 1) = .Range("A" & i)
           
            i = i - 1
        Wend
        DebMerge = i
        .Range(.Cells(DebMerge, 1), .Cells(FinMerge, 2)).Merge
    Next i
   
   
    'mise en forme
    Range("A2").Resize(Fin, LastCol).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    Columns("A:K").Select
    Columns("A:K").EntireColumn.AutoFit
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End With
End Sub
 

Bullosphere

XLDnaute Nouveau
POur éviter d'avoir à rajouter les noms de feuilles à chaque fois, voici une modif qui ne travaille que sur les feuilles dont le nom est un nombre (2017 2018...)
VB:
Sub Stat()
Dim tablo() As Variant
Application.ScreenUpdating = False

With Sheets("Statistique")
    .UsedRange.Offset(1, 0).Clear
End With

For Each ws In Sheets
    On Error Resume Next
    erreur = CInt(ws.Name)
    If erreur <> "" Then
   ' If ws.Name <> "Statistique" And ws.Name <> "Liste donnée" And ws.Name <> "Liste de choix" And ws.Name <> "Ancienne" And ws.Name <> "Nombre de bouteilles total" Then
        With ws
            Set ici = .Range("C:D").Find("Total", lookat:=xlPart) 'recherche de la ligne "Total..."
            If Not ici Is Nothing Then
                Fin = ici.Row - 2
            End If
            LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
            tablo = .Range("A2").Resize(Fin, LastCol).Value
        End With
        For i = LBound(tablo, 1) To UBound(tablo, 1)
            If tablo(i, 5) - tablo(i, 6) <= 0 Then
                For j = LBound(tablo, 2) To UBound(tablo, 2)
                    tablo(i, j) = ""
                Next j
            End If
        Next i
  
    With Sheets("Statistique")
        Fin = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & Fin).Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
    End With
    erreur = ""
    End If
Next ws

With Sheets("Statistique")
  
    Application.DisplayAlerts = False
    Fin = .Range("A" & .Rows.Count).End(xlUp).Row + 1
    .Range("A1").Resize(Fin, LastCol).AutoFilter Field:=3, Criteria1:="="
    .Range("A2").Resize(Fin, LastCol).SpecialCells(xlCellTypeVisible).Delete
    .Range("A1").Resize(Fin, LastCol).AutoFilter
    Fin = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("B2:B" & Fin).ClearContents
  
    'tri sur la colonne A et C pour regrouper les domaines et Type de vin
    ActiveWorkbook.Worksheets("Statistique").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Statistique").Sort.SortFields.Add Key:=Range("A2:A" & Fin), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Statistique").Sort.SortFields.Add Key:=Range("C2:C" & Fin), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Statistique").Sort
        .SetRange Range("A2").Resize(Fin, LastCol)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
  
    For i = Fin To 2 Step -1
        FinMerge = i
        DebMerge = i
        While .Range("A" & i - 1) = .Range("A" & i)
          
            i = i - 1
        Wend
        DebMerge = i
        .Range(.Cells(DebMerge, 1), .Cells(FinMerge, 2)).Merge
    Next i
  
  
    'mise en forme
    Range("A2").Resize(Fin, LastCol).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    Columns("A:K").Select
    Columns("A:K").EntireColumn.AutoFit
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End With
End Sub

Bonjour,

Je reviens vers vous pour cette macro qui fonctionne très bien mais elle est très lente il faut environ 30 min pour qu'il effectue la macro, y a t'il possibilité d'améliorer la rapidité de la macro ?

Je vous rejoint le fichier.

Merci par avance
 

Pièces jointes

  • 01-Echantillon Vin.xlsm
    777.4 KB · Affichages: 6

vgendron

XLDnaute Barbatruc
hello

un essai avec ceci
VB:
Sub Stat()
Dim tablo() As Variant
Application.ScreenUpdating = False
Application.Calculation = xlManual
With Sheets("Statistique")
    .UsedRange.Offset(1, 0).Clear
End With
For Each ws In Sheets
    If ws.Name <> "Statistique" And ws.Name <> "Liste donnée" And ws.Name <> "Liste de choix" And ws.Name <> "Nombre de bouteilles total" And ws.Name <> "Nombre de bouteilles par type" And ws.Name <> "Livre" Then
        With ws
            Set ici = .Range("C:D").Find("Total", lookat:=xlPart) 'recherche de la ligne "Total..."
            If Not ici Is Nothing Then
                fin = ici.Row - 2
            End If
            'fin = 327
            LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
            tablo = .Range("A2").Resize(fin, LastCol).Value
        End With
        For i = LBound(tablo, 1) To UBound(tablo, 1)
            If tablo(i, 5) - tablo(i, 6) <= 0 Then
                For j = LBound(tablo, 2) To UBound(tablo, 2)
                    tablo(i, j) = ""
                Next j
            End If
        Next i
   
    With Sheets("Statistique")
        fin = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & fin).Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
    End With
    End If
Next ws
With Sheets("Statistique")
    Application.DisplayAlerts = False
    fin = .Range("A" & .Rows.Count).End(xlUp).Row + 1
    tablo = .Range("A2").Resize(fin, 12).Value
    taillefinale = 1
    For i = LBound(tablo, 1) To UBound(tablo, 1)
        If tablo(i, 1) <> "" Then taillefinale = taillefinale + 1
    Next i
    ReDim tablofinal(1 To taillefinale, 1 To 12)
    k = 1
    For i = LBound(tablo, 1) To UBound(tablo, 1)
        If tablo(i, 1) <> "" Then
            For j = LBound(tablo, 2) To UBound(tablo, 2)
                tablofinal(k, j) = tablo(i, j)
            Next j
            k = k + 1
        End If
    Next i
    .UsedRange.Offset(1, 0).Clear
    .Range("A2").Resize(UBound(tablofinal, 1), UBound(tablofinal, 2)) = tablofinal
'    .Range("A1").Resize(fin, LastCol).AutoFilter Field:=3, Criteria1:="="
'    .Range("A2").Resize(fin, LastCol).SpecialCells(xlCellTypeVisible).Delete
'    .Range("A1").Resize(fin, LastCol).AutoFilter
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("B2:B" & fin).ClearContents
    'tri sur la colonne A et C pour regrouper les domaines et Type de vin
    ActiveWorkbook.Worksheets("Statistique").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Statistique").Sort.SortFields.Add Key:=Range("A2:A" & fin), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Statistique").Sort.SortFields.Add Key:=Range("C2:C" & fin), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Statistique").Sort
        .SetRange Range("A2").Resize(fin, LastCol)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    For i = fin To 2 Step -1
        FinMerge = i
        DebMerge = i
        While .Range("A" & i - 1) = .Range("A" & i)
            i = i - 1
        Wend
        DebMerge = i
        .Range(.Cells(DebMerge, 1), .Cells(FinMerge, 2)).Merge
    Next i
    'mise en forme
    Range("A2").Resize(fin, LastCol).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    Columns("A:K").Select
    Columns("A:K").EntireColumn.AutoFit
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
End With
End Sub

ce qui prenait du temps, c'est la suppression des lignes vides ==>
solution de contournement
je refais un tableau de tout ce qui a été copié dans la feuille statistique
je fais un second tableau avec uniquement les lignes NON vides
j'efface la feuille stat
et je recolle
 

Discussions similaires

Réponses
4
Affichages
256

Statistiques des forums

Discussions
311 725
Messages
2 081 947
Membres
101 849
dernier inscrit
florentMIG