Demande d'aide macro copier coller catégories

**audreyportiere** · 03/10/2018, 14h34

Bonjour,

J’aurais besoin de vos lumières, j’ai un fichier excel avec plusieurs colonnes.
J’aimerais récupérer dans un nouveau fichier les informations des colonnes des 200 premières lignes par catégories (colonne AK et AJ),:
Ex : 200 lignes de CAROTTE de lille puis les 200 lignes CAROTTES PARIS, puis CAROTTES MARSEILLES
Ensuite les 200 premières lignes de POIREAU de lille puis les 200 lignes POIREAU PARIS, puis POIREAU MARSEILLE, si je n’ai pas de poireau à marseille, je n’aurais pas de ligne.

Vous trouverez ci-joint un exemple du fichier

J’espère que j’ai été assez claire, sinon n’hésitez pas à revenir vers moi.

Merci beaucoup pour votre aide

Bonne journée

Audrey

**Thautheme** · 03/10/2018, 16h41

Bonjour Audrey, bonjour le forum,

Une proposition avec le code ci-dessous. Un nouveau classeur est créé et les 200 premières lignes de chaque catégorie sont placéee dans un onglet différent de ce nouveau classeur... Dis-nous si ça convient...

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
Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Dstination)
Dim TV As Variant 'déclare la variable TV (Tableau ds Valeurs)
Dim NL As Long 'déclare la variable NL (Nombre de Lignes)
Dim NC As Integer 'déclare la variable NC (Nombre de Colonnes)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Long 'déclare la variable K (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
 
Set CS = ThisWorkbook 'définit le classeur source CS
Set OS = CS.Worksheets("Feuil1") 'définit l'onglet source OS
Set CD = Workbooks.Add 'définit le classeur destination CD (ouvre un classeur vierge)
TV = OS.Range("A1").CurrentRegion 'définit la tableau des valeurs TV
NL = UBound(TV, 1) 'définit le nombre de lignes NL du tableau des valeurs TV
NC = UBound(TV, 2) 'définit le nombre de colonnes NC du tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le ditionnaire D
For I = 2 To NL 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    D(TV(I, 36) & "-" & TV(I, 37)) = "" 'alimente le dictionnaire avec la donnée en colonne 36 (=>AJ), un tiret de séparation, et la donnée en colonne 37 (=>AK) de la ligne de la boucle
Next I 'prochaine ligne de la boucle
TMP = D.Keys 'récupère dans le tableau temporaire TMP la liste des élément du dictionnaire D sans doublon
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments du tableau temporaire tmp
    K = 1: Erase TL 'initialise la variable K, vide le tableau TL
    For I = 2 To NL 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
        'condition : si la donnée en colonne 36, un tiret de séparation et la donnée de la colonne 37 de la boucle 2 correspondent à l'élément de la boucle 1
        If TV(I, 36) & "-" & TV(I, 37) = TMP(J) Then
            ReDim Preserve TL(1 To NC, 1 To K) 'redimensionnee tableau des ligne TL (autant de lignes que TV a de colonnes, K colonnes)
            For L = 1 To NC 'bocule 3 : sur toutes les colonnes L du tableau des valeurs TV
                TL(L, K) = TV(I, L) 'récupère dans la ligne L de TL la donnée en colonne L de TV (=transposition)
            Next L 'prochaine colonne de la boucle 3
            K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
            If K = 201 Then GoTo suite 'si K est égale à 201, va à l'étiquette suite (pour ne prendre que les 200 premières lignes de chaque catégorie)
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
suite: 'étiquette
    CD.Activate 'active le classeur destination CD
    CD.Worksheets.Add after:=CD.Worksheets(Sheets.Count) 'ajoute un onglet en dernière position
    Set OD = ActiveSheet 'définit l'onglet OD
    OD.Name = TMP(J) 'renomme l'onglet OD
    OD.Range("A1").Resize(1, NC) = Application.Index(TV, 1) 'renvoie la première ligne du tableau des valeurs TV dans A1 redimansionnée de l'onglet OS
    OD.Range("A2").Resize(K - 1, NC) = Application.Transpose(TL) 'renvoie le tableau des lignes transposé dans A2 redimensionnée de l'onglet OS
Next J 'prochain élément de la boucle 1
Application.DisplayAlerts = False 'masque les messages d'alerte d'excel (quand un onglet est supprimé par exemple)
For Each OS In CD.Sheets 'boucle sur tous les onglets OS du classeur destination CD
    If Left(OS.Name, 5) = "Feuil" Then OS.Delete 'si le nom de l'onglet commence par "Feuil", supprime l'onglet (à adapter selon la langue)
Next OS 'prochain onglet de la boucle
Application.DisplayAlerts = True 'affiche les messages d'alerte d'excel
End Sub

**audreyportiere** · 03/10/2018, 17h06

Merci beaucoup Thautheme pour votre réactivité, c'est vraiment pas mal ce que vous avez fait

, serait-il possible de compiler les différents onglets qui ont été créés en un seul, car j'ai besoin que les données n'apparaissent que sur une seule feuille.

En vous remerciant

Audrey

**Thautheme** · 03/10/2018, 17h20

Re,

Le code adapté :

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
Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim NL As Long 'déclare la variable NL (Nombre de Lignes)
Dim NC As Integer 'déclare la variable NC (Nombre de Colonnes)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Long 'déclare la variable K (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim DL As Long 'déclare la variable DL (Dernière Ligne)
 
Set CS = ThisWorkbook 'définit le classeur source CS
Set OS = CS.Worksheets("Feuil1") 'définit l'onglet source OS
Set CD = Workbooks.Add 'définit le classeur destination CD (ouvre un classeur vierge)
TV = OS.Range("A1").CurrentRegion 'définit la tableau des valeurs TV
NL = UBound(TV, 1) 'définit le nombre de lignes NL du tableau des valeurs TV
NC = UBound(TV, 2) 'définit le nombre de colonnes NC du tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le ditionnaire D
For I = 2 To NL 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    D(TV(I, 36) & "-" & TV(I, 37)) = "" 'alimente le dictionnaire avec la donnée en colonne 36 (=>AJ), un tiret de séparation, et la donnée en colonne 37 (=>AK) de la ligne de la boucle
Next I 'prochaine ligne de la boucle
TMP = D.Keys 'récupère dans le tableau temporaire TMP la liste des élément du dictionnaire D sans doublon
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments du tableau temporaire tmp
    K = 1: Erase TL 'initialise la variable K, vide le tableau TL
    For I = 2 To NL 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
        'condition : si la donnée en colonne 36, un tiret de séparation et la donnée de la colonne 37 de la boucle 2 correspondent à l'élément de la boucle 1
        If TV(I, 36) & "-" & TV(I, 37) = TMP(J) Then
            ReDim Preserve TL(1 To NC, 1 To K) 'redimensionnee tableau des ligne TL (autant de lignes que TV a de colonnes, K colonnes)
            For L = 1 To NC 'bocule 3 : sur toutes les colonnes L du tableau des valeurs TV
                TL(L, K) = TV(I, L) 'récupère dans la ligne L de TL la donnée en colonne L de TV (=transposition)
            Next L 'prochaine colonne de la boucle 3
            K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
            If K = 201 Then GoTo suite 'si K est égale à 201, va à l'étiquette suite (pour ne prendre que les 200 premières lignes de chaque catégorie)
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
suite: 'étiquette
    CD.Activate 'active le classeur destination CD
    Set OD = CD.Sheets(1) 'définit l'onglet OD (premier onglet du classeur destination)
    OD.Range("A1").Resize(1, NC) = Application.Index(TV, 1) 'renvoie la première ligne du tableau des valeurs TV dans A1 redimensionnée de l'onglet OS
    DL = OD.Cells(Application.Rows.Count, "A").End(xlUp).Row + 1 'définit la dernière ligne éditée DL de la colonne A de l'onglet OD
    OD.Cells(DL, "A").Resize(K - 1, NC) = Application.Transpose(TL) 'renvoie le tableau des lignes transposé dans la cellule ligbe DL colonne A redimensionnée de l'onglet OS
Next J 'prochain élément de la boucle 1
End Sub

**audreyportiere** · 03/10/2018, 17h24

Oh là là, vous travaillez plus vite que la lumière, je vais tester la macro en grandeur nature et je reviendrais vers vous demain pour le verdict.

Merci beaucoup

**audreyportiere** · 03/10/2018, 17h58

Mr Thautheme, c'est encore moi, j'ai testé la macro grandeur nature et j'ai un bug, vous trouverez le fichier dans le lien ci-dessous.
Est-ce parce que mon fichier fait plus de 200000 lignes ?

https://we.tl/t-8yVp4kmBfF

N'hésitez pas à revenir vers moi si vous avez des questions.

Merci beaucoup pour votre aide précieuse.

Audrey

**Thautheme** · 04/10/2018, 14h50

Bonjour Audrey, bonjour le forum,

La macro modifiée et testée sur ton fichier. Ça semble fonctionner correctement.

le code :

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
Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim NL As Long 'déclare la variable NL (Nombre de Lignes)
Dim NC As Integer 'déclare la variable NC (Nombre de Colonnes)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Long 'déclare la variable K (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim DL As Long 'déclare la variable DL (Dernière Ligne)
 
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CS = ThisWorkbook 'définit le classeur source CS
Set OS = CS.Worksheets("Feuil1") 'définit l'onglet source OS
Set CD = Workbooks.Add 'définit le classeur destination CD (ouvre un classeur vierge)
TV = OS.Range("A1").CurrentRegion 'définit la tableau des valeurs TV
NL = UBound(TV, 1) 'définit le nombre de lignes NL du tableau des valeurs TV
NC = UBound(TV, 2) 'définit le nombre de colonnes NC du tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le ditionnaire D
For I = 2 To NL 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    D(TV(I, 36) & "-" & TV(I, 37)) = "" 'alimente le dictionnaire avec la donnée en colonne 36 (=>AJ), un tiret de séparation, et la donnée en colonne 37 (=>AK) de la ligne de la boucle
Next I 'prochaine ligne de la boucle
TMP = D.Keys 'récupère dans le tableau temporaire TMP la liste des élément du dictionnaire D sans doublon
OS.Rows(1).Copy CD.Worksheets(1).Range("A1") 'copie la première ligne du tableau des valeurs dans la cellule A1 du premier onglet du classeur destination
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments du tableau temporaire tmp
    K = 1: Erase TL 'initialise la variable K, vide le tableau TL
    For I = 2 To NL 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
        'condition : si la donnée en colonne 36, un tiret de séparation et la donnée de la colonne 37 de la boucle 2 correspondent à l'élément de la boucle 1
        If TV(I, 36) & "-" & TV(I, 37) = TMP(J) Then
            ReDim Preserve TL(1 To NC, 1 To K) 'redimensionnee tableau des ligne TL (autant de lignes que TV a de colonnes, K colonnes)
            For L = 1 To NC 'bocule 3 : sur toutes les colonnes L du tableau des valeurs TV
                TL(L, K) = TV(I, L) 'récupère dans la ligne L de TL la donnée en colonne L de TV (=transposition)
            Next L 'prochaine colonne de la boucle 3
            K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
            If K = 201 Then GoTo suite 'si K est égale à 201, va à l'étiquette suite (pour ne prendre que les 200 premières lignes de chaque catégorie)
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
suite: 'étiquette
    CD.Activate 'active le classeur destination CD
    Set OD = CD.Sheets(1) 'définit l'onglet OD (premier onglet du classeur destination)
    DL = OD.Cells(Application.Rows.Count, "A").End(xlUp).Row + 1 'définit la dernière ligne éditée DL de la colonne A de l'onglet OD
    OD.Cells(DL, "A").Resize(K - 1, NC) = Application.Transpose(TL) 'renvoie le tableau des lignes transposé dans la cellule ligbe DL colonne A redimensionnée de l'onglet OS
Next J 'prochain élément de la boucle 1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Transfert des données terminé !" 'message
End Sub

**audreyportiere** · 04/10/2018, 15h51

Mais ça fonctionne plus que bien, c'est magnifyyyyyyyyyque.

Si j'osais, je vous demanderai encore une petite modification, mais je pense que c'est impossible à réaliser même au meilleur des développeurs, informaticiens, créateur...
Bon je tente quand même par ce que vous êtes très bon

Est-ce qu'il est possible que dans mon fichier il me sélectionne 1000 CHOCOLAT de CLERMONT et non 200 comme pour les autres, on ne touche pas aux autres ingrédients, 200 c'est parfait.
Si vous n'y arrivez pas, ce n'est pas grave, vous avez déjà fait beaucoup pour moi.

Merci

Audrey

Demande d'aide macro copier coller catégories

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager