XL 2016 Boucle copier-coller

A

AngieMot33

XLDnaute Nouveau
Bonjour,

Je suis débutante en macros VBA et j'ai un souci dans l'exécution de la macro dans le fichier ci- joint, il y a quelque chose que j'ai raté car elle ne me ramène pas tous les éléments que je souhaite.

Je m'explique et j'espère que ce sera clair 😅 :

Dans la feuille COMPIL BPU il y a en colonne B une liste de codes.
Ce que je demande à la macro c'est d'aller chercher dans toutes les lignes de la feuille TOUTES PRESTATIONS (extrait pour forum mon fichier d'origine contient environ 15000 lignes) tous les codes commençant par le code de la colonne B (Exemple mon code EXTI950 en B9) et me les copier dans les colonnes de F à O (J'ai prévu jusqu'à 10 finalités différentes existantes par code), puis passer à la ligne suivante jusqu'à la dernière ligne de la colonne B.

Il y a certainement un problème dans la boucle car pour le code cité en exemple il me ramène 3 codes au lieu de 5 (il ne me ramène pas les codes EXTI950-GEP et EXTI950-SINIS.
De plus il répète le dernier code trouvé dans toutes les colonnes jusqu'à K.

Je tourne en rond depuis plus d'une semaine, pourriez- vous me débloquer svp 🙏?
 

Pièces jointes

  • CTRL PRESTA BPU POUR CONSULTATION.xlsm
    89.9 KB · Affichages: 7
Solution
vgendron
hello

comme tu as un fichier final avec beaucoup de lignes, je conseille de travailler avec des tableaux VBA
voici un code qui devrait aller plus vite que tes boucles
VB: 
Sub ExtrairePresta()

Dim TabCompil() As Variant 'déclaration d'un tablo vba
Dim TabPresta() As Variant 'déclaration d'un tablo vba

Set dico = CreateObject("Scripting.dictionary") 'déclaration d'un dictionnaire

With Sheets("Compil BPU") 'avec la feuille
    LastLine = .Range("B" & .Rows.Count).End(xlUp).Row 'dernière ligne non vide de la colonne B
    TabCompil = .Range("B2:F" & LastLine).Value 'on met les données de la colonne B à F dans le tablo
End With

With Sheets("Toutes Prestations") 'avec la feuille
    LastLine = .Range("B" & .Rows.Count).End(xlUp).Row...
Trier par date Trier par votes
Cousinhub

Cousinhub

XLDnaute Barbatruc
Inactif
Bonjour,
Pour faire ce que tu désires, je ne suis pas passé par une macro, mais en utilisant Power Query, en natif dans ta version d'Excel.
Pour mener à bien la requête, j'ai transformé tes plages en Tableaux Structurés (TS) :
- Premier Onglet, TS nommé "T_Data" (et qui, dans ton fichier exemple, va de A1 à E162)
- Deuxième Onglet, TS nommé "T_Presta" (de A2 à AP230) - Attention, ça commence en ligne 2 car les titres sont dans cette ligne
Je les ai fusionnés dans la requête, et cette requête est restituée dans le premier onglet, à partir de la cellule G1
Cette requête va s'adapter automatiquement au nombre max de prestation pour 1 code (les 10 finalités que tu avais prévues, mais qui pourraient être supérieures...)
Pour mettre à jour la requête, tu fais un clic droit dans une cellule de la requête, puis "Actualiser" (ou ruban "Données, "Actualiser tout")
Si ça peut te convenir
Bonne journée
 

Pièces jointes

  • PQ_Fusion et Répartition en colonnes selon nb.xlsx
    88.3 KB · Affichages: 3
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
hello

comme tu as un fichier final avec beaucoup de lignes, je conseille de travailler avec des tableaux VBA
voici un code qui devrait aller plus vite que tes boucles
VB: 
Sub ExtrairePresta()

Dim TabCompil() As Variant 'déclaration d'un tablo vba
Dim TabPresta() As Variant 'déclaration d'un tablo vba

Set dico = CreateObject("Scripting.dictionary") 'déclaration d'un dictionnaire

With Sheets("Compil BPU") 'avec la feuille
    LastLine = .Range("B" & .Rows.Count).End(xlUp).Row 'dernière ligne non vide de la colonne B
    TabCompil = .Range("B2:F" & LastLine).Value 'on met les données de la colonne B à F dans le tablo
End With

With Sheets("Toutes Prestations") 'avec la feuille
    LastLine = .Range("B" & .Rows.Count).End(xlUp).Row 'dernière ligne non vide de la colonne B
    TabPresta = .Range("B2:D" & LastLine).Value 'on met les données de la colonne B à D dans le tablo
End With

For i = LBound(TabCompil, 1) To UBound(TabCompil, 1) 'pour chaque ligne = pour chaque code de prestation
    clé = TabCompil(i, 1) 'on récupère le code
    For j = LBound(TabPresta, 1) To UBound(TabPresta, 1) 'pour chaque ligne du tableau
        If TabPresta(j, 1) = clé Then 'si on est sur le bon code
            valeur = TabPresta(j, 3) 'on récupère la donnée
            If Not dico.exists(clé) Then 'si l'entrée dico n'existe pas
                dico.Add clé, valeur 'on ajoute l'entrée avec la valeur
            Else
                dico(clé) = dico(clé) & "/" & valeur 'sinon, on ajoute la valeur, séparéé d'un /
            End If
        End If
    Next j
    TabCompil(i, 5) = dico(clé) 'on inscrit le résultat dans la dernière colonne du tablo
Next i

'on inscrit le résultat dans la feuille
With Sheets("Compil BPU")
    For i = LBound(TabCompil, 1) To UBound(TabCompil, 1)
        If TabCompil(i, 5) <> "" Then
            'MsgBox UBound(Split(TabCompil(i, 5), "-"))
            .Range("F" & i + 1).Resize(, UBound(Split(TabCompil(i, 5), "/")) + 1) = Split(TabCompil(i, 5), "/")
        End If
    Next i
End With

End Sub
 
Vote positif 0 Vote négatif
Solution
A

AngieMot33

XLDnaute Nouveau
Cousinhub à dit:
Bonjour,
Pour faire ce que tu désires, je ne suis pas passé par une macro, mais en utilisant Power Query, en natif dans ta version d'Excel.
Pour mener à bien la requête, j'ai transformé tes plages en Tableaux Structurés (TS) :
- Premier Onglet, TS nommé "T_Data" (et qui, dans ton fichier exemple, va de A1 à E162)
- Deuxième Onglet, TS nommé "T_Presta" (de A2 à AP230) - Attention, ça commence en ligne 2 car les titres sont dans cette ligne
Je les ai fusionnés dans la requête, et cette requête est restituée dans le premier onglet, à partir de la cellule G1
Cette requête va s'adapter automatiquement au nombre max de prestation pour 1 code (les 10 finalités que tu avais prévues, mais qui pourraient être supérieures...)
Pour mettre à jour la requête, tu fais un clic droit dans une cellule de la requête, puis "Actualiser" (ou ruban "Données, "Actualiser tout")
Si ça peut te convenir
Bonne journée
Cliquez pour agrandir...
Bonjour Cousin Hub,
Merci beaucoup c'est top, cela répond à mes attentes toutefois, je ne maîtrise pas du tout Power Query donc je vais chercher à me former pour pouvoir comprendre, et voir réutiliser ta méthode. Merci pour le temps passé.
Je vais rester sur une macro pour l'instant.
 
Vote positif 0 Vote négatif
A

AngieMot33

XLDnaute Nouveau
vgendron à dit:
hello

comme tu as un fichier final avec beaucoup de lignes, je conseille de travailler avec des tableaux VBA
voici un code qui devrait aller plus vite que tes boucles
VB: 
Sub ExtrairePresta()

Dim TabCompil() As Variant 'déclaration d'un tablo vba
Dim TabPresta() As Variant 'déclaration d'un tablo vba

Set dico = CreateObject("Scripting.dictionary") 'déclaration d'un dictionnaire

With Sheets("Compil BPU") 'avec la feuille
    LastLine = .Range("B" & .Rows.Count).End(xlUp).Row 'dernière ligne non vide de la colonne B
    TabCompil = .Range("B2:F" & LastLine).Value 'on met les données de la colonne B à F dans le tablo
End With

With Sheets("Toutes Prestations") 'avec la feuille
    LastLine = .Range("B" & .Rows.Count).End(xlUp).Row 'dernière ligne non vide de la colonne B
    TabPresta = .Range("B2:D" & LastLine).Value 'on met les données de la colonne B à D dans le tablo
End With

For i = LBound(TabCompil, 1) To UBound(TabCompil, 1) 'pour chaque ligne = pour chaque code de prestation
    clé = TabCompil(i, 1) 'on récupère le code
    For j = LBound(TabPresta, 1) To UBound(TabPresta, 1) 'pour chaque ligne du tableau
        If TabPresta(j, 1) = clé Then 'si on est sur le bon code
            valeur = TabPresta(j, 3) 'on récupère la donnée
            If Not dico.exists(clé) Then 'si l'entrée dico n'existe pas
                dico.Add clé, valeur 'on ajoute l'entrée avec la valeur
            Else
                dico(clé) = dico(clé) & "/" & valeur 'sinon, on ajoute la valeur, séparéé d'un /
            End If
        End If
    Next j
    TabCompil(i, 5) = dico(clé) 'on inscrit le résultat dans la dernière colonne du tablo
Next i

'on inscrit le résultat dans la feuille
With Sheets("Compil BPU")
    For i = LBound(TabCompil, 1) To UBound(TabCompil, 1)
        If TabCompil(i, 5) <> "" Then
            'MsgBox UBound(Split(TabCompil(i, 5), "-"))
            .Range("F" & i + 1).Resize(, UBound(Split(TabCompil(i, 5), "/")) + 1) = Split(TabCompil(i, 5), "/")
        End If
    Next i
End With

End Sub
Cliquez pour agrandir...
Wouah ! je l'ai adapté à mon utilisation, car j'avais copié un extrait de l'onglet TOUTES PRESTATIONS pour le fichier de demande d'aide.
Juste une chose, j'ai l'habitude de travailler le VBA en version explicite, et je l'ai supprimé pour que le code fonctionne, car il bloquait sur Set dico et je n'ai pas su adapter par contre....

Sub ExtrairePresta()

Dim TabCompil() As Variant 'déclaration d'un tablo vba
Dim TabPresta() As Variant 'déclaration d'un tablo vba

' Ouvrir les fichiers X et Y
Set wbX = Workbooks.Open("H:\DJSILD\DJSILD-LD\11 - Ulis NG\00 - PRESTATIONS\000 - Outils recherche et contrôles\PRESTATIONS_VBA_EN CONSTRUCTION\SQL-TOUTES PRESTATIONS EN BASE PROD_V1-2023-LIVE OFFICE.xlsx")
Set wbY = ThisWorkbook

' Définir les feuilles de calcul
Set wsX = wbX.Sheets("TOUTES PRESTATIONS")
Set wsY = wbY.Sheets("COMPIL BPU")

Set dico = CreateObject("Scripting.dictionary") 'déclaration d'un dictionnaire

Set wbX = Workbooks.Open("H:\DJSILD\DJSILD-LD\11 - Ulis NG\00 - PRESTATIONS\000 - Outils recherche et contrôles\PRESTATIONS_VBA_EN CONSTRUCTION\SQL-TOUTES PRESTATIONS EN BASE PROD_V1-2023-LIVE OFFICE.xlsx")

With wbY.Sheets("Compil BPU") 'avec la feuille
LastLine = .Range("B" & .Rows.Count).End(xlUp).Row 'dernière ligne non vide de la colonne B
TabCompil = .Range("B2:F" & LastLine).Value 'on met les données de la colonne B à F dans le tablo
End With

With wbX.Sheets("Toutes Prestations") 'avec la feuille
LastLine = .Range("B" & .Rows.Count).End(xlUp).Row 'dernière ligne non vide de la colonne B
TabPresta = .Range("B2:D" & LastLine).Value 'on met les données de la colonne B à D dans le tablo
End With

For i = LBound(TabCompil, 1) To UBound(TabCompil, 1) 'pour chaque ligne = pour chaque code de prestation
clé = TabCompil(i, 1) 'on récupère le code
For j = LBound(TabPresta, 1) To UBound(TabPresta, 1) 'pour chaque ligne du tableau
If TabPresta(j, 1) = clé Then 'si on est sur le bon code
valeur = TabPresta(j, 3) 'on récupère la donnée
If Not dico.exists(clé) Then 'si l'entrée dico n'existe pas
dico.Add clé, valeur 'on ajoute l'entrée avec la valeur
Else
dico(clé) = dico(clé) & "/" & valeur 'sinon, on ajoute la valeur, séparéé d'un /
End If
End If
Next j
TabCompil(i, 5) = dico(clé) 'on inscrit le résultat dans la dernière colonne du tablo
Next i

'on inscrit le résultat dans la feuille
With wbY.Sheets("Compil BPU")
For i = LBound(TabCompil, 1) To UBound(TabCompil, 1)
If TabCompil(i, 5) <> "" Then
'MsgBox UBound(Split(TabCompil(i, 5), "-"))
.Range("F" & i + 1).Resize(, UBound(Split(TabCompil(i, 5), "/")) + 1) = Split(TabCompil(i, 5), "/")
End If
Next i
End With

End Sub
 
Vote positif 0 Vote négatif
A

AngieMot33

XLDnaute Nouveau
vgendron à dit:
hello

comme tu as un fichier final avec beaucoup de lignes, je conseille de travailler avec des tableaux VBA
voici un code qui devrait aller plus vite que tes boucles
VB: 
Sub ExtrairePresta()

Dim TabCompil() As Variant 'déclaration d'un tablo vba
Dim TabPresta() As Variant 'déclaration d'un tablo vba

Set dico = CreateObject("Scripting.dictionary") 'déclaration d'un dictionnaire

With Sheets("Compil BPU") 'avec la feuille
    LastLine = .Range("B" & .Rows.Count).End(xlUp).Row 'dernière ligne non vide de la colonne B
    TabCompil = .Range("B2:F" & LastLine).Value 'on met les données de la colonne B à F dans le tablo
End With

With Sheets("Toutes Prestations") 'avec la feuille
    LastLine = .Range("B" & .Rows.Count).End(xlUp).Row 'dernière ligne non vide de la colonne B
    TabPresta = .Range("B2:D" & LastLine).Value 'on met les données de la colonne B à D dans le tablo
End With

For i = LBound(TabCompil, 1) To UBound(TabCompil, 1) 'pour chaque ligne = pour chaque code de prestation
    clé = TabCompil(i, 1) 'on récupère le code
    For j = LBound(TabPresta, 1) To UBound(TabPresta, 1) 'pour chaque ligne du tableau
        If TabPresta(j, 1) = clé Then 'si on est sur le bon code
            valeur = TabPresta(j, 3) 'on récupère la donnée
            If Not dico.exists(clé) Then 'si l'entrée dico n'existe pas
                dico.Add clé, valeur 'on ajoute l'entrée avec la valeur
            Else
                dico(clé) = dico(clé) & "/" & valeur 'sinon, on ajoute la valeur, séparéé d'un /
            End If
        End If
    Next j
    TabCompil(i, 5) = dico(clé) 'on inscrit le résultat dans la dernière colonne du tablo
Next i

'on inscrit le résultat dans la feuille
With Sheets("Compil BPU")
    For i = LBound(TabCompil, 1) To UBound(TabCompil, 1)
        If TabCompil(i, 5) <> "" Then
            'MsgBox UBound(Split(TabCompil(i, 5), "-"))
            .Range("F" & i + 1).Resize(, UBound(Split(TabCompil(i, 5), "/")) + 1) = Split(TabCompil(i, 5), "/")
        End If
    Next i
End With

End Sub
Cliquez pour agrandir...
Merci beaucoup !!!!
 
Vote positif 0 Vote négatif

Discussions similaires

misteryann
  • Question
XL 2016 Adapter un code à mon fichier (RESOLU)
Réponses
4
Affichages
254
misteryann
misteryann
J
  • Résolu(e)
Microsoft 365 [RESOLU] VBA boucle, insertion plusieurs lignes, exécution formules, suppression sur si
Réponses
5
Affichages
430
Phil69970
Phil69970
F
  • Question
XL 2016 Recherche multi classeurs
Réponses
5
Affichages
198
mromain
mromain
D
  • Question
XL 2019 Contrôle active x qui se transforme en contrôle formulaires
Réponses
2
Affichages
297
Dranreb
Dranreb
A
  • Question
XL 2016 Colorer en vert le besoin effectif par rapport au stock
Réponses
2
Affichages
163
job75
job75
N
  • Résolu(e)
Microsoft 365 Macro copier/coller entre deux tableaux structurés
3 4 5
Réponses
66
Affichages
1 K
job75
job75
P
  • Résolu(e)
XL 2021 Besoin d'aide pour copier/coller données de plusieurs classeurs
2
Réponses
20
Affichages
677
Pac41240
P
N
  • Résolu(e)
Microsoft 365 Rechercher la dernière cellule saisie dans un TS et ajouter l'heure système
18 19 20
Réponses
291
Affichages
67 K
NONO14
N
C
  • Question
Microsoft 365 Mise en forme conditionnelle recherche V par feuille
Réponses
2
Affichages
252
JHA
J
chris6999
  • Question
Microsoft 365 MACRO VBA - Extraire des listes à partir d'une boucle
Réponses
5
Affichages
451
chris6999
chris6999

Membres actuellement en ligne

13 membres et 101 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 096
Messages
2 116 175
Membres
112 677
dernier inscrit
Justine11