Copy Coller avec AdvancedFilter

Version imprimable

Voir 40 message(s) de cette discussion en une page

30/06/2020, 10h19
78chris

Bonjour

Chez moi pour quelques comptes c'est instantané mais cela m'intéresse de savoir combien tu en as et de voir tes adaptations...

@suivre
30/06/2020, 16h04
iliesss

Citation:

Envoyé par 78chris

Bonjour

Chez moi pour quelques comptes c'est instantané mais cela m'intéresse de savoir combien tu en as et de voir tes adaptations...

@suivre

Merci Mr Chris
Je suis entraîne de travailler pour le nouveau code il me reste quelle que lignes.
@suivre

1 pièce(s) jointe(s)

Bonjour
voici mon final
Option Explicit

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
Sub Copy_Avec_AdvancedFilter()
    Dim oSheetData   As Excel.Worksheet
    Dim ShGrLvr As Worksheet
    Dim ShActuelle As Worksheet
    Dim RgData As Range, RgCriter As Range
    Dim DerLig As Long, DerLigW As Long, i As Long, LastRow As Long, LastRowSolde As Long
    Dim Cpt As String
 
    Set ShGrLvr = ThisWorkbook.Worksheets("Grand livre")
    Set RgData = ShGrLvr.Range("TablGrLivre[#All]")
    Set RgCriter = ShGrLvr.Range("TablCritere[#All]")
    DerLig = ShGrLvr.Cells(ShGrLvr.Rows.Count, 1).End(xlUp).Row
 
     With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
    If ShGrLvr.FilterMode = True Then
        ShGrLvr.ShowAllData
    End If
 
ShGrLvr.Columns("W").ClearContents
ShGrLvr.Range("E1:E" & DerLig).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ShGrLvr.Range("W1"), Unique:=True
DerLigW = ShGrLvr.Cells(ShGrLvr.Rows.Count, 23).End(xlUp).Row
 
For i = 2 To DerLigW
    ShGrLvr.Range("P2").Value = ShGrLvr.Range("W" & i).Value
    Cpt = ShGrLvr.Range("P2").Value
        If SheetExist(Cpt) Then
            Set ShActuelle = ThisWorkbook.Worksheets(Cpt)
            LastRow = ShActuelle.Cells(ShActuelle.Rows.Count, 1).End(xlUp).Row + 4
            RgData.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=RgCriter, CopyToRange:=ShActuelle.Cells(LastRow, 1)
            ShActuelle.Rows(LastRow - 3 & ":" & LastRow).Delete Shift:=xlUp
        Else
            Sheets("Masque").Copy After:=Sheets(Sheets.Count)
            Set oSheetData = Sheets(Sheets.Count)
            oSheetData.Name = Cpt
            Set ShActuelle = ThisWorkbook.Worksheets(Cpt)
            LastRow = ShActuelle.Cells(ShActuelle.Rows.Count, 1).End(xlUp).Row + 1
            RgData.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=RgCriter, CopyToRange:=ShActuelle.Cells(LastRow, 1)
            ShActuelle.Rows(LastRow & ":" & LastRow).Delete Shift:=xlUp
        End If
Next i
 
For Each oSheetData In ThisWorkbook.Worksheets
    With oSheetData
        If .Name <> "Grand livre" And .Name <> "Masque" Then
            LastRowSolde = oSheetData.Cells(oSheetData.Rows.Count, 1).End(xlUp).Row
            oSheetData.Range("G6").Value = oSheetData.Range("I" & LastRowSolde).Value
            oSheetData.Columns("I:J").ClearContents
            oSheetData.Range("F" & LastRowSolde + 1).Value = "TOTAUX"
            oSheetData.Range("G" & LastRowSolde + 1).FormulaLocal = "=SOUS.TOTAL(9;G9:G" & LastRowSolde & " )"
            oSheetData.Range("H" & LastRowSolde + 1).FormulaLocal = "=SOUS.TOTAL(9;H9:H" & LastRowSolde & "  )"
            oSheetData.Range("F" & LastRowSolde + 2).Value = "SOLDE COMPTABLE RECTIFI"
            oSheetData.Range("G" & LastRowSolde + 2).FormulaLocal = "=G" & (LastRowSolde + 1) & "-H" & (LastRowSolde + 1) & ""
            oSheetData.Range("F" & LastRowSolde + 3).Value = "DIFF"
            oSheetData.Range("G" & LastRowSolde + 3).FormulaLocal = "=G6" & "-G" & (LastRowSolde + 2) & ""
        End If
    End With
Next oSheetData
 
With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
End With
 
Application.CutCopyMode = False
 
End Sub
Function SheetExist(strSheetName As String) As Boolean
    Dim i As Integer
 
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = strSheetName Then
            SheetExist = True
            Exit Function
        End If
 
    Next i
End Function

et voila le fichier

Svp S'il y a une modification pour améliorer ou augmenter la vitesse d’exécution du code aidez moi
merci

01/07/2020, 16h23
78chris

Bonjour

Je vois que tu as abandonné PowerQuery...

Effectivement le filtre avancé est ici plus rapide (moins d'une seconde sur mon PC)

Merci de retour
01/07/2020, 23h35
iliesss

Bonjour
Oui j'ai constaté que advencefiltre est très rapide vu le nombre de ligne à ventilé
Svp Mr Chris ou quelqu'un de forum s'il ya une modification dans le code ça me fait plaisir et merci à tous
02/07/2020, 07h54
Philippe Tulliez

Bonjour,

Citation:

Oui j'ai constaté que advencefiltre est très rapide vu le nombre de ligne à ventilé

Evidemment que cette méthode est rapide, j'exporte 64000 lignes avec 50 colonnes dont certaines avec formules en deux secondes et même si certain peuvent trouver cette méthode dépassée, je l'utilise toujours en clientèle.
De plus je pilote toutes mes applications avec un tableau extérieure où je place tous les paramètres nécessaires (Sort, Filter, etc.)

Cela a le gros avantage d'être mise en place rapidement

En ce qui concerne ta procédure, tu pratiques exactement comme je le fais, liste unique placée deux colonnes à droite de la liste des données, sauf que to, tu utilises une adresse absolue alors que moi je la calcule automatiquement, cela rend plus perenne l'application

Voir un billet Créer une liste unique de données contenues dans une colonne d'un tableau structuré à ce sujet

Voir 40 message(s) de cette discussion en une page