Microsoft 365 Copier des données avec conditions à l'aide d'une macro

[Coralie01120]

Bonjour,

J'ai besoin de votre aide. Je bloque sur une macro qui paraît simple mais je ne sais pas du tout par où commencer...

Voici mon besoin : Je souhaite venir copier des données en y intégrant des conditions.

J'ai simplifié au maximum les données dans les deux fichiers ci-joint.

Le classeur BDD change tous les mois, il est composé de :
Colonne A = N° travaux
Colonne B = Outil utilisé

Le classeur CONSO est composé de :
Colonne A = N° travaux
Colonne B = Outil utilisé
Objectif de la macro :
Venir copier dans le tableau du classeur CONSO les N° de travaux du classeur BDD en enlevant les deux derniers chiffres et en ne faisant qu'1 ligne par travaux et en ne copiant pas les travaux sans outils associés en colonne B et s''il y a plusieurs outils utilisés faire une autre ligne en dessous.

Dans le classeur CONSO, les données affichées sont les résultats attendus.

Je vous remercie pour votre aide.
Bonne fin de journée.

 

[fanfan38]

Bonjour
Ci joint ma solution par macro
sinon tu peux utiliser power query tuto: https://www.excel-downloads.com/media/categories/power-query.5/
A+ François

 

[job75]

Bonsoir Coralie01120, François,

Sauf erreur de ma part les noms des outils peuvent avoir plusieurs lettres comme "marteau".

Le séparateur étant le tiret utiliser la fonction Split(xxx, "-") pour les distinguer.

A+

 

[job75]

Bonjour Coralie01120, François, le forum,

Voici une solution VBA assez élaborée :

Sub MAJ()
Dim chemin$, fichier$, sep1$, sep2$, d As Object, tablo, i&, x$, xx$, s, j%, y$, n&, dest As Range
chemin = ThisWorkbook.Path & "\" 'à adapter
fichier = "BDD.xlsx" 'à adapter
sep1 = " " 'séparateur 1ère colonne
sep2 = "-" 'séparateur 2ème colonne
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
On Error Resume Next
Workbooks(fichier).Close False 'si le fichier est ouvert
Err = 0
With Workbooks.Open(chemin & fichier)
    If Err Then MsgBox "'" & fichier & "' introuvable !", 48: Exit Sub
    tablo = .Sheets(1).UsedRange.Resize(, 2) 'matrice, plus rapide
    .Close False
End With
On Error GoTo 0
For i = 1 To UBound(tablo)
    x = tablo(i, 1): xx = tablo(i, 2)
    If x <> "" And xx <> "" Then
        x = Split(x, sep1)(0)
        s = Split(xx, sep2)
        For j = 0 To UBound(s)
            xx = Trim(s(j))
            y = x & Chr(1) & xx
            If Not d.exists(y) Then
                d(y) = ""
                n = n + 1
                tablo(n, 1) = x: tablo(n, 2) = xx
            End If
        Next j
    End If
Next i
'---restitution---
With Feuil1 'CodeName
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    Set dest = .[B3] '1ère cellule du tableau, à adapter
    With .Cells(.Rows.Count, dest.Column).End(xlUp)(2) '1ère cellule vide
        If n Then
            .Resize(n, 2) = tablo
            .Resize(n, 3).Borders.Weight = xlThin 'bordures
        End If
    End With
    dest.CurrentRegion.RemoveDuplicates Array(1, 2), Header:=xlNo 'supprime les doublons
End With
End Sub

L'exécution est très rapide car on utilise un tableau VBA et le Dictionary.

Téléchargez les fichiers joints dans le même dossier (le bureau).

A+

 

[Coralie01120]

Bonsoir,

Merci pour votre aide. Les deux solutions répondent à mon problème.
Je vous remercie pour votre précieuse aide.
Bonne soirée

 

[Coralie01120]

Bonjour
Ci joint ma solution par macro
sinon tu peux utiliser power query tuto: https://www.excel-downloads.com/media/categories/power-query.5/
A+ François

Bonjour Fanfan38,

Votre solution fonctionne mais comme l'a souligné Job75 l'outil est composé de plusieurs lettres et chiffres (ex : XMC02154788). Comment faire pour faire apparaître l'ensemble de l'outil et non pas que la première lettre ?
J'ai tenté la fonction Split comme énoncé mais je n'arrive pas à l'intégrer...
Cordialement,

 

[fanfan38]

Bonjour
le fichier de JOB75 (Salut JOB75) répond parfaitement à ton problème…
Veux tu que je modifie quand même ma proposition?
A+ François

 

[Coralie01120]

Bonjour
le fichier de JOB75 (Salut JOB75) répond parfaitement à ton problème…
Veux tu que je modifie quand même ma proposition?
A+ François

Bonjour,
Je veux bien une version avec votre proposition car je n’arrive pas à appliquer celle de Job75 sur mon fichier...

 

[job75]

Bonjour Coralie01120, fanfan38,

je n’arrive pas à appliquer celle de Job75 sur mon fichier...

Vous n'avez sans doute pas compris qu'il faut adapter With Feuil1 dans la macro.

Remplacez Feuil1 par le CodeName de la feuille à gauche de (Tableau) dans VBA.

A+

 

[Coralie01120]

Bonjour,

Votre macro compare les deux fichiers si je ne dis pas de bêtise.

Mon fichier BDD a des colonnes séparant les données Travaux et Outils ce qui n'est pas le cas pour le fichier CONSO. Du coup la macro ne fonctionne plus sur mon fichier.

Avec la macro de Fanfan38 je peux adapter les colonnes...

Je vous remercie

 

[job75]

Il suffisait (et il vous suffit) de joindre des fichiers qui correspondent à la réalité !!!

J'adapterai la macro.

 

[fanfan38]

J'espère avoir résolu ton problème
A+ François

 

[Coralie01120]

J'espère avoir résolu ton problème
A+ François

Bonjour,

Super ! Tout fonctionne parfaitement. Merci pour votre précieuse aide à vous deux.

Bonne journée

 

[job75]

Mon fichier BDD a des colonnes séparant les données Travaux et Outils ce qui n'est pas le cas pour le fichier CONSO.

Pour que ce soit compréhensible j'ai ajouté une colonne intermédiaire dans le fichier BDD.

Voyez ce fichier (2) et les 2 corrections sur la macro :

With Workbooks.Open(chemin & fichier)
    If Err Then MsgBox "'" & fichier & "' introuvable !", 48: Exit Sub
    tablo = .Sheets(1).UsedRange.Resize(, 3) 'matrice, plus rapide, sur 3 colonnes
    .Close False
End With
On Error GoTo 0
For i = 1 To UBound(tablo)
    x = tablo(i, 1): xx = tablo(i, 3)

 

[job75]

Ah mais puisqu'à la fin RemoveDuplicates supprime les doublons pas besoin de Dictionary.

Voyez ce fichier (3) et cette macro, plus simple :

Sub MAJ()
Dim chemin$, fichier$, sep1$, sep2$, tablo, i&, x$, xx$, s, j%, n&, dest As Range
chemin = ThisWorkbook.Path & "\" 'à adapter
fichier = "BDD.xlsx" 'à adapter
sep1 = " " 'séparateur 1ère colonne
sep2 = "-" 'séparateur 2ème colonne
Application.ScreenUpdating = False
On Error Resume Next
Workbooks(fichier).Close False 'si le fichier est ouvert
Err = 0
With Workbooks.Open(chemin & fichier)
    If Err Then MsgBox "'" & fichier & "' introuvable !", 48: Exit Sub
    tablo = .Sheets(1).UsedRange.Resize(, 3) 'matrice, plus rapide, sur 3 colonnes
    .Close False
End With
On Error GoTo 0
For i = 1 To UBound(tablo)
    x = tablo(i, 1): xx = tablo(i, 3)
    If x <> "" And xx <> "" Then
        x = Split(x, sep1)(0)
        s = Split(xx, sep2)
        For j = 0 To UBound(s)
            xx = Trim(s(j))
            n = n + 1
            tablo(n, 1) = x: tablo(n, 2) = xx
        Next j
    End If
Next i
'---restitution---
With Feuil1 'CodeName
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    Set dest = .[B3] '1ère cellule du tableau, à adapter
    With .Cells(.Rows.Count, dest.Column).End(xlUp)(2) '1ère cellule vide
        If n Then
            .Resize(n, 2) = tablo
            .Resize(n, 3).Borders.Weight = xlThin 'bordures
        End If
        
    End With
    dest.CurrentRegion.RemoveDuplicates Array(1, 2), Header:=xlNo 'supprime les doublons
    .Range(.Cells(.Rows.Count, dest.Column).End(xlUp)(2), .Rows(.Rows.Count)).Delete 'car il y a des lignes vides en bas du Usedrange
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub

Edit : ajouté la suppression des lignes vides en bas du UsedRange.