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
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

chris6999
  • Question
Microsoft 365 MACRO VBA - Extraire des listes à partir d'une boucle
Réponses
5
Affichages
205
chris6999
chris6999
C
  • Question
XL 2016 Copier et coller une valeur dans plusieurs Listobjects d'une même feuille
Réponses
5
Affichages
238
chris
chris
G
  • Résolu(e)
XL 2013 copier coller valeur d'une colonne dynamique
Réponses
13
Affichages
337
gwenn49
G
W
  • Question
XL 2021 Boucle copier-coller par nom d'en-tête de colonnes
Réponses
10
Affichages
322
whiteshark
W
M
  • Résolu(e)
Microsoft 365 Code incomplet
5 6 7
Réponses
93
Affichages
2 K
Marvin57
M
S
  • Résolu(e)
Autres Copier-Coller en recherchant une ligne spécifique VBA
Réponses
4
Affichages
290
sambio2
S
T
  • Résolu(e)
XL 2010 Formule - Copier une formule dans toutes les lignes de la colonne C
Réponses
6
Affichages
102
tchi456
T
A
  • Résolu(e)
Microsoft 365 Insérer des lignes et copier VBA
Réponses
3
Affichages
181
Lolote83
L
F
  • Question
XL 2016 copier valeurs en vba
Réponses
10
Affichages
521
Fidmo
F
L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
81
Latias
L

Membres actuellement en ligne

10 membres et 99 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
312 215
Messages
2 086 316
Membres
103 176
dernier inscrit
jean.yvesjean.yves