Recherche + Copie de ligne

**Toggesh** · 18/07/2017, 16h08

Bonjour,

Je suis en train de construire des macros pour extraire des données d'un fichier Excel très lourd (25Mo) pour les filtrer et calculer des moyennes glissante et faire des graphiques au final

mais avant d'en arriver là...

Déjà je ne connais pas le VBA

Néanmoins, j'ai réussi à faire pas mal de petite chose

avec les différentes infos trouvé sur le forum et ailleurs. Par contre, je suis un peu bloqué.

Je cherche à faire une macro qui séparer les lignes en fonction des noms de la colonne A. Je m'explique.

J'ai une centaine de colonne (avec un calendrier sur les 3 première ligne, des titres de colonne sur la ligne 4, et plus de 2500 lignes de donnée).

Je souhaites donc que la macro :
1/ regarde les noms qui sont dans la colonne A de la ligne 5 à 3000 (voir jusqu'à la dernière ligne rempli) + les noms dans la colonne D (même nbre de ligne que A). Je souhaite quelques choses de plus complexe en terme de filtre mais je vais voir pour le faire en plusieurs étapes.
2/ sélection toutes les lignes avec le même nom A et B puis les copies dans une nouvelle feuille. (qu'elle le fasse pour tous les différents noms, s'il y a 10noms je veux qu'il y ait 10 feuilles).

Attention un des problèmes c'est que je ne connais pas tous les noms de la colonne A et D et qu'ils sont nombreux. Donc il faut que la macro se débrouille.

Je pense que ça me permettra d'aller plus loin dans mon codage je ne pense pas qu'il sera optimum mais s'il fonctionne dans un premier temps ça sera déjà par mal.

Merci de votre aide

exemple_data.xlsx

**Toggesh** · 18/07/2017, 18h21

Pour être une peu plus clair et en lien avec l'exemple, je voudrai mettre toutes les lignes contenant "Chien" dans la colonne D et "azerty" dans la colonne A dans une autre feuille excel.

Cela va me donner plusieurs ligne, je voudrai donc faire une moyenne glissante à +/-1 colonne. Dans mon idée, j'aurai fait l'addition en bas de chaque colonne puis fait la moyenne glissante sur une ligne en dessous.

Ensuite j'aimerai copier cette ligne moyenné dans une autre feuille

Le top serait de pouvoir mettre toutes les séries "chien" dans la même feuille et ressortir les lignes de moyenne de chaque série "azerty", "qwerty", etc... dans autre feuille les une en dessous des autres. ça me permettra d'avoir déjà plus ou moins la mise en forme pour le futur graphique.

Mon problème est surtout cette histoire de recherche multiple + copie de ligne

**Toggesh** · 18/07/2017, 20h37

J'ai essayé le code suivant qui fonctionne bien, mais j'aimerai remplacer "azerty" et "chien" par item1 de la field 1 et item1 de la field 4, est-ce possible ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Sub Filtre()
    Rows("5:5").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$5:$K$320").AutoFilter Field:=1, Criteria1:="azerty"
    ActiveSheet.Range("$A$5:$K$320").AutoFilter Field:=4, Criteria1:="chien"
End Sub

**riaolle** · 19/07/2017, 08h32

Récupérer toutes le associations sans doublons
Filtrer sur chaque association et copier-coller le résultat du filtre

1. Récupérer toutes les association sans doublons :

Recopier la liste complète (copier la feuille)
Eliminer les doublons sur les 2 premières colonnes : en manuel, tu utilises Données > Outils de données > Supprimer les doublons. Tu peux récupérer le code correspond grâce à l'enregistreur de macro (code à adapter !)

--> tu as une liste des mots sur lesquels tu devras filtrer.

2. Filtrer sur chaque association :
Tu as déjà un début de code pour filtrer. Il suffit de faire une boucle sur la liste établies dans le point 1 et filtrer sur ces mots.

**Toggesh** · 19/07/2017, 09h56

Pas tout a fait car je ne souhaites pas supprimer les doublons mais faire des calculs de moyenne dessus pour pouvoir faire un graph au finale.

J'ai fait sur mon exemple tout à la main pour montrer ce que je cherche à faire au final.

j'espère que ça sera plus clair.

exemple_data_2.xlsx

**riaolle** · 19/07/2017, 10h23

A priori, pas besoin de VBA : regarde du côté des tableaux croisés dynamiques !

**halaster08** · 20/07/2017, 09h25

Envoyé par Toggesh

Je cherche à faire une macro qui séparer les lignes en fonction des noms de la colonne A. Je m'explique.

Bonjour,
Essaye ceci:
Vu que c'est sur ta colonne A, il y a juste le nom de la feuille a adapter (ligne 10 environ)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub OngletsNom()
'cette macro sépare les données ,de la feuille dont le nom est dans la variable data, en une feuille par valeur différentes
'cette macro n'a pas besoin que les données soient triées car elle utilise les filtres avancés.
 
Application.ScreenUpdating = False
Dim FEUILLE_DEST As Worksheet
Dim var As Object
Dim Plage As Range
Dim Cell As Range
Dim i As Long
Data = "RSS_data" 'nom de la feuille des données (a adapter)
 
' création de l'objet SortedList
Set var = CreateObject("System.Collections.SortedList")
 
 
With ThisWorkbook.Worksheets(Data).Cells(1, 1)
    Set Plage = .CurrentRegion  ' plage des données (avec les titres)
    For Each Cell In .CurrentRegion.Columns(1).Cells   ' boucle pour créer la liste sans doublon
        If Not var.containskey(Cell.Value) And Cell.Row > 1 Then
            var.Add Cell.Value, Cell.Text
        End If
    Next Cell
End With
 
 
For i = 0 To var.Count - 1
 
    ' ici on gère le fait que la feuille existe ou non
    On Error Resume Next
        Set FEUILLE_DEST = ThisWorkbook.Worksheets(Plage.Cells(1, 1) & "_" & var.getbyindex(i))
    On Error GoTo 0
 
    ' si la feuille n'existe pas : on la crée et la renomme avec le nom de la var
    If FEUILLE_DEST Is Nothing Then
        Set FEUILLE_DEST = ThisWorkbook.Worksheets.Add
        FEUILLE_DEST.Name = Plage.Cells(1, 1) & "_" & var.getbyindex(i)
        FEUILLE_DEST.Move After:=Sheets(ActiveWorkbook.Sheets.Count)
 
    ' si la feuille existe : on efface tout
    Else
        FEUILLE_DEST.Cells.Clear
    End If
 
    ' utilisation du filtre avancé
    With FEUILLE_DEST
        .Cells(1, 1) = Plage.Cells(1, 1) ' nom du critère (l'entête de la colonne 1)
        .Cells(2, 1) = var.getbyindex(i)            ' valeur du critère : nom de la var (qui est le nom de la feuille)
        Plage.AdvancedFilter xlFilterCopy, .Cells(1, 1).CurrentRegion, .Cells(4, 1), False  ' application du filtre avancé
        .Cells(1, 1).Resize(3, 1).EntireRow.Delete ' nettoyage de la zone des critères (= suppression des lignes 1 à 3)
    End With
 
    Set FEUILLE_DEST = Nothing
Next i
 
 
Application.ScreenUpdating = True
End Sub

**Toggesh** · 20/07/2017, 12h15

Merci pour ton code je vais regarder dans le détail pour comprendre le code et ne pas faire d'erreur en cas de modif.

Sinon petite question, comment fait on un test type

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
If (critere2) "différent" critere2 Then
 
GoTo FINMACRO2
 
Else
 
LISTE DE COMMANDE POUR LA MACRO
 
End If

**Toggesh** · 21/07/2017, 11h11

Bon je vais faire ça avec Do Loop ça sera plus propre.

**Toggesh** · 24/07/2017, 13h58

J'avance doucement.

Petite question, c'est quoi l'écart entre :

Rows ("5:5")

Rows (5)

Rows ("5:7")

Car j'ai différent code et parfois ça fonctionne et parfois non et je ne comprends pas pourquoi.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
 
 
Dim DLBDM As Long 'derniere ligne de la base de donnée filtré pour savoir quoi copier
 
'Sélection + Copie des données filtré
    DLBDM = Sheets("Base de donnéeM").Range("A5").End(xlDown).Row
    Sheets("Base de donnéeM").Rows("5:" & DLBDM).Copy
    Sheets(critere1).Rows("5:5").Insert Shift:=xlDown 'insert les lignes copier
    Sheets(critere1).Rows("5:7").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 'insert des lignes vide pour les calculs <= je fais ça car j'ajoute pas le haut et donc il faut faire decendre les données
    Sheets(critere1).Rang("A7") = "Moyen & critere2" ' nomme la ligne moyenne pour la retrouver plutard

ça, ça ne fonctionne pas. Ça ne colle pas les éléments copié malgré que ça semble bien sélectionné et copier les éléments idem pour les opérations suivante (insertion de 3 lignes vide + remplissage de la cellule A7.

En revanche un peu plus haut j'ai

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
 
    On Error Resume Next
    Set Sheet = Worksheets(critere1)
    If Err.Number <> 0 Then
    'si elle est présente ajoute une feuille avec le nom
    Sheets.Add.Name = critere1
    Sheets("Base de donnéeM").Rows("1:4").Copy 'Copie des lignes
    Sheets(critere1).Rows("1:1").Insert Shift:=xlDown 'insert les lignes copier
    Else
    End If
 
    Worksheets("Base de donnéeM").Activate
 
    'Ajout du filtre et application du filtre sur la base de donnéeM
    Rows("4:4").AutoFilter
    ActiveSheet.Range("$A$1:$K$316").AutoFilter Field:=1, Criteria1:=critere2
    ActiveSheet.Range("$A$1:$K$316").AutoFilter Field:=4, Criteria1:=critere1

et ça, ça marche nickel.

**riaolle** · 24/07/2017, 14h08

J'écris toujours :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Rows(1)....
'ou
Range("1:1")....
 
'et
Range("1:5")....  'pas Rows("1:5")

Attention,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Sheets(critere1).Range("A7") = "Moyen & critere2"

Faute de frappe ?

**Klin89** · 26/07/2017, 22h59

Bonsoir à tous,

Toggesh, c'est ce genre de tableaux que tu souhaites obtenir
A tester, restitution en Feuil1 préalablement créée

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
Sub test()
Dim a, e, v, w(), i As Long, j As Long, n As Long, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("Base de donnée")
        a = .Range("a1").CurrentRegion.Value
        For i = 2 To UBound(a, 1)
            If Not dico.exists(a(i, 4)) Then
                Set dico(a(i, 4)) = CreateObject("Scripting.Dictionary")
                dico(a(i, 4)).CompareMode = 1
            End If
            If Not dico(a(i, 4)).exists(a(i, 1)) Then
                ReDim w(1 To UBound(a, 2) - 2, 1 To 3)
            Else
                w = dico(a(i, 4))(a(i, 1))
                ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
            End If
            w(1, UBound(w, 2) - 2) = a(i, 4)
            w(2, UBound(w, 2) - 2) = a(i, 1)
            For j = 3 To UBound(w, 1)
                w(j, UBound(w, 2) - 2) = a(i, j + 2)
            Next
            dico(a(i, 4))(a(i, 1)) = w
        Next
        For Each e In dico.keys
            For Each v In dico(e).keys
                w = dico.Item(e).Item(v)
                w(1, UBound(w, 2) - 1) = e: w(1, UBound(w, 2)) = e
                w(2, UBound(w, 2) - 1) = v: w(2, UBound(w, 2)) = v
                For i = 3 To UBound(w, 1)
                    w(i, UBound(w, 2) - 1) = _
                    Application.Sum(Application.Index(w, i, Evaluate("row(1:" & UBound(w, 2) - 2 & ")")))
                Next
                For i = 4 To UBound(w, 1) - 1
                    w(i, UBound(w, 2)) = _
                    Application.Average(Application.Index(w, Evaluate("row(" & i - 1 & ":" & i + 1 & ")"), UBound(w, 2) - 1))
                Next
                dico.Item(e).Item(v) = w
            Next
        Next
    End With
    'Restitution
    With Sheets("Feuil1").Range("a1")
        .Parent.Cells.Clear
        n = 1
        For i = 0 To dico.Count - 1
            For j = 0 To dico.items()(i).Count - 1
                With .Offset(n).Resize(1, UBound(dico.items()(i).items()(j), 1))
                    .Value = _
                    Application.Transpose(Application.Index(dico.items()(i).items()(j), , UBound(dico.items()(i).items()(j), 2)))
                End With
                n = n + 1
            Next
            With .Offset(n - 1).CurrentRegion.Resize(dico.items()(i).Count, UBound(dico.items()(0).items()(0), 1))
                .BorderAround Weight:=xlThin
            End With
            n = n + 1
        Next
    End With
    Set dico = Nothing
End Sub

klin89

Recherche + Copie de ligne [XL-2013]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager