Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

B

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
Trier par date Trier par votes

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
 
Vote positif 0 Vote négatif
B

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:
Vote positif 0 Vote négatif
B

Bullosphere

XLDnaute Nouveau
pour cette question :
Connaissez vous une formule qui permet de le faire ?
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif
B

Bullosphere

XLDnaute Nouveau

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
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Résolu(e)
Microsoft 365 Ajout d'onglet par VBA et entête de colonnes
2
Réponses
17
Affichages
937
Roseline
  • Question Question
XL 2016 rajouter une colonne en macro
Réponses
0
Affichages
98
richardlion
R
  • Question Question
XL 2016 "#valeur!" dans ligne et colonne et camemberts
Réponses
7
Affichages
275
Rikko14
R
  • Question Question
XL 2019 masquer une colonne si vide
Réponses
12
Affichages
525
job75
G
  • Résolu(e)
Microsoft 365 Colorer des cellules automatiquement
Réponses
14
Affichages
484
Gaugau
G
  • Question Question
Microsoft 365 Ajout de formule sur tableau
2
Réponses
16
Affichages
522
FredeX
C
  • Résolu(e)
XL 2016 Ajustement automatique de la largeur d'une colonne
Réponses
5
Affichages
103
Phil69970
U
  • Résolu(e)
Autres [RESOLU] Ajout dans macro mais où sans trop de casse!!!
Réponses
8
Affichages
459
crocrocro
C
  • Question Question
XL 2021 Calcul jours, TCD et outil de pilotage via TCD
Réponses
6
Affichages
159
Raziel abel
J
  • Résolu(e)
XL 2021 Coloriser une cellule avec un click d'une colonne
Réponses
10
Affichages
217
TooFatBoy
W
  • Résolu(e)
Microsoft 365 VBA Ajouter une colonne à droite avec mise en forme
Réponses
6
Affichages
206
fanch55
Y
  • Question Question
Microsoft 365 VBA - Basculer des lignes d'onglet en onglet selon un critère
2
Réponses
18
Affichages
716
yanus
Y
R
  • Question Question
Microsoft 365 Tableau de progressions
Réponses
10
Affichages
270
Rosario.
R
  • Résolu(e)
XL 2013 Effacer le contenu si la valeur n'est pas entre 13000 90000 et copier les valeurs dupliqués
Réponses
8
Affichages
195
lestoiles1
D
  • Résolu(e)
Microsoft 365 Remplissage colonne automatique dépendant d'un tableau
Réponses
7
Affichages
561
fanfan38
  • Question Question
Microsoft 365 "concatener" certaines colonnes d'onglets
2
Réponses
15
Affichages
757
Phil69970
O
  • Question Question
Autres recopie de cellules selon la date
Réponses
3
Affichages
112
olivier Clech
O
C
  • Question Question
XL 2010 Recherche de colonne et calcul sur 2 années consécutives
Réponses
0
Affichages
225
CS49
C
H
  • Question Question
XL 2013 Saisie sécurisée numéros de téléphone et ajout fonction clic droit de la souris
2
Réponses
21
Affichages
662
Helios77
H
F
  • Résolu(e)
Power Query Power Query : chercher si une colonne existe et la renommer
Réponses
7
Affichages
233
Florent74
F
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…