Macro pour écrire dans un autre classeur

Version imprimable

11/05/2021, 09h47
Thomas_MC

Macro pour écrire dans un autre classeur

Bonjour à tous,

J'ai 2 classeurs, 1 et 2.
Le 1, c'est un classeur excel classique xls sans macro activable qui récapitule des entrées et des retours de courriers.
Le 2 est un classeur dont je peux faire ce que je veux (ou presque). Ce classeur récapitule une partie des opérations effectuées, notamment sur une partie du courrier.

J'aimerais à l'aide de la référence de courriers traités dans le classeur 2 inscrire la date de retour de courrier dans le classeur 1.

En gros, vérifier la présence ou non d'une référence de courrier dans les 2 classeurs et si dans le classeur 1, il n'y a pas de date de retour inscrite (et uniquement, il ne faudrait pas les écraser), inscrire la date présente dans le classeur 2.

Pour information, j'ai environ 20000 lignes déjà dans le classeur 1 et environ 4000 dans le classeur 1

Pourriez vous m'aider?

Merci beaucoup d'avance,

T.

Je n'ai pas accès au power query, j'ai un admin système qui bloque tout... :roll:

1 pièce(s) jointe(s)

Salut.

Sur base de tableaux structurés (t_Check à gauche qui envoie les données dans t_Courrier à droite), le principe est de parcourir t_Check, de cherche la ligne correspondante dans t_Courrier et si la ligne est trouvée, d'y balancer la date si elle est vide dans t_Courrier

Pièce jointe 597755
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Sub Test() Dim SourceRow As Long Dim TargetRow Dim TargetTable As ListObject Set TargetTable = Workbooks("Base.xlsx").Worksheets(1).ListObjects(1) For SourceRow = 1 To Range("t_Check").Rows.Count TargetRow = Application.Match(Range("t_Check[courrier]")(SourceRow), TargetTable.ListColumns("Courrier").DataBodyRange, 0) If Not IsError(TargetRow) Then If TargetTable.ListColumns("Date").DataBodyRange(TargetRow).Value = "" Then _ TargetTable.ListColumns("Date").DataBodyRange(TargetRow).Value = Range("t_check[Date]")(SourceRow).Value End If Next SourceRow End Sub
Je suis parti de l'idée que le classeur cible est ouvert, mais le principe est identique s'il est fermé, on l'ouvre pour en récupérer le tableau placé sur la feuille souhaitée. Perso, dans mes classeurs pro, j'utilise une fonction générique pour récupérer un tableau dont je connais le nom dans un classeur...

2 pièce(s) jointe(s)

Bonjour,

Une façon de faire, à tester et adapter:

Code:

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
Option Explicit
 
'--- suppose les 2 fichiers déjà ouverts et que dans les 2 fichiers:
'--- la colonne 1 (A) contient les références (sans doublon)
'--- la colonne 2 (B) contient les dates
 
Sub AjoutDate()
    Dim wSh1 As Worksheet, wSh2 As Worksheet
    Dim rData1 As Range, rData2 As Range
    Dim r As Range, rRef2 As Range
    '--- initialiser
    Application.DisplayStatusBar = True
    Application.ScreenUpdating = False
    Set wSh1 = Workbooks("Dates1.xlsx").Worksheets("Feuil1")
    Set wSh2 = ThisWorkbook.Worksheets("Feuil1")
    wSh1.Cells.AutoFilter Field:=2, Criteria1:="="      '--- 2 = colonne B, date vide
    wSh2.Cells.AutoFilter Field:=2, Criteria1:="<>"     '--- 2 = colonne B, date non vide
    Set rData1 = wSh1.UsedRange.SpecialCells(xlCellTypeVisible)
    Set rData2 = wSh2.UsedRange.SpecialCells(xlCellTypeVisible)
    '--- parcourir les lignes où la date manque
    For Each r In rData1.Rows
        Application.StatusBar = r.Row
        If r.Row > 1 Then                               '--- saute la ligne de titre
            'Debug.Print r.Address, r.Cells(1, 1).Value,
            Set rRef2 = rData2.Find(r.Cells(1, 1).Value, , xlValues, xlWhole, xlByColumns)
            If rRef2 Is Nothing Then
                'Debug.Print "---"
            Else
                'Debug.Print rRef2.Address, rRef2.Offset(0, 1).Value, rRef2.Cells(1, 2).Value
                r.Cells(1, 2).Value = rRef2.Cells(1, 2).Value
            End If
        End If
    Next r
    '--- nettoyer
    wSh1.Cells.AutoFilter
    wSh2.Cells.AutoFilter
    Set rData1 = Nothing
    Set rData2 = Nothing
    Set wSh1 = Nothing
    Set wSh2 = Nothing
    Application.ScreenUpdating = True
End Sub

Cordialement.

13/05/2021, 19h52
Pierre Fauconnier

Attention qu'un Cells.Autofilter plante sur une feuille contenant un tableau structuré. Or, en 2021, on peut espérer que les tableaux structurés sont utilisés dans les situations telles que celle exposée ici ;)
14/05/2021, 14h54
Thomas_MC

2 pièce(s) jointe(s)

Cela a l'air super. j'ai pigé la première moitié du code, mais je n'ai pas tout à fait compris l'opération d'écriture de la date en elle même (à partir de la boucle R) et du coup, je n'arrive pas à l'adapter à mes colonnes...
:(
Voici en pièce jointe mes deux fichiers (ultra simplifiés bien sûr).

(le fichier transfert étant celui dans lequel je mets la macro évidement)

Pièce jointe 597822 Pièce jointe 597823

Bonjour,

Effectivement, n'utilise toujours pas les tableaux structurés. C'est l'effet clavier AZERTY: on continue de l'utiliser simplement parce qu'on a commencé avec cela ... il y a bien longtemps!

En supposant que c'est le fichier 'Courrier' qui doit recevoir les dates encodées dans le fichier 'Transfert' et que ce qui est la référence unique (sans doublon) dans chacun de ces 2 fichiers est le n° de facture, le code (à placer dans le fichier 'Transfert') serait celui-ci:

Code:

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
Option Explicit
 
'--- suppose que dans les 2 fichiers:
'--- n° facture SANS DOUBLON dans aucun des 2 fichiers, non vérifié par cette macro
 
Sub AjoutDate()
    Dim wSh1 As Worksheet, wSh2 As Worksheet
    Dim rData1 As Range, rData2 As Range
    Dim r As Range, rRef2 As Range
    '--- initialiser
    Application.DisplayStatusBar = True
    Application.ScreenUpdating = False
    Set wSh1 = Workbooks("Courrier test.xlsx").Worksheets("Feuil1")
    Set wSh2 = ThisWorkbook.Worksheets("Feuil1")
    wSh1.Cells.AutoFilter Field:=10, Criteria1:="="      '--- 10 = colonne J, date vide (dans Courrier)
    wSh2.Cells.AutoFilter Field:=11, Criteria1:="<>"     '--- 11 = colonne K, date non vide (dans Transfert)
    Set rData1 = wSh1.UsedRange.SpecialCells(xlCellTypeVisible)
    Set rData2 = wSh2.UsedRange.SpecialCells(xlCellTypeVisible)
    '--- parcourir ligne par ligne le fichier "Courrier" (ligne où Date vide en colonne J)
    For Each r In rData1.Rows
        Application.StatusBar = r.Row
        If r.Row > 3 Then                                   '--- 3 = n° ligne de titre fichier Courrier
            Debug.Print r.Address, r.Cells(1, 6).Value,
            '--- r.Cells(1, 6).Value = n° facture dans fichier "Courrier"
            '--- cherche cellule dans fichier "Transfert" contenant ce n° de facture
            Set rRef2 = rData2.Find(r.Cells(1, 6).Value, , xlValues, xlWhole, xlByColumns) '--- 6 = colonne F
            If rRef2 Is Nothing Then
                Debug.Print "---"
            Else
                Debug.Print rRef2.Address, rRef2.Offset(0, 4).Value
                r.Cells(1, 10).Value = rRef2.Offset(0, 4).Value '--- 10 = colonne J
            End If
        End If
    Next r
    '--- nettoyer
    wSh1.Cells.AutoFilter
    wSh2.Cells.AutoFilter
    Set rData1 = Nothing
    Set rData2 = Nothing
    Set wSh1 = Nothing
    Set wSh2 = Nothing
    Application.ScreenUpdating = True
End Sub

Cordialement.

14/05/2021, 17h16
Pierre Fauconnier

Citation:

Envoyé par EricDgn

[...]
Effectivement, n'utilise toujours pas les tableaux structurés.[...]

C'est dommage qu'en 2021 on continue à utiliser des plages classiques lorsque l'on devrait utiliser des tableaux structurés qui simplifient à peu près tout tant en Excel qu'en VBA, et c'est dommage également que l'on continue à proposer des solutions "classiques" (c'est-à-dire obsolètes, à mon estime) au lieu de forcer à l'utilisation des tableaux structurés, qui plus est en proposant du code qui ne fonctionne qu'avec des plages classiques et qui modifient l'interface de l'utilisateur (suppression des filtres et tris mis éventuellement en place précédemment) alors qu'on peut s'en passer... :(

2 pièce(s) jointe(s)

Bonjour,

Juste pour l'exemple, la même chose en utilisant les tableaux structurés.

A noter qu'il est présumé que c'est le champ n° facture qui sert d'identifiant unique (sans doublon) dans les 2 fichiers.

Problème non résolu: il arrive que ce n° facture soit au format "texte" dans un fichier et au format "nombre" dans l'autre. Dans ce cas, la fonction MATCH ne permet pas de retrouver le n°. Il faut donc s'assurer que ces n° soient bien tous au même format dans les 2 fichiers avant de lancer cette macro.

Code:

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
Option Explicit
 
Sub AjoutDates()
    Dim SourceRow As Long, TargetRow As Variant
    Dim SourceTable As ListObject, TargetTable As ListObject
    Dim rSourceFact As Range, rTargetFact As Range
    Dim rSourceDate As Range, rTargetDate As Range
    '--- Source=origine: tTransfert --- Target=cible: tCourrier
    '--- intialiser
    Set SourceTable = ThisWorkbook.Worksheets("Feuil1").ListObjects("tTransfert")
    Set rSourceFact = SourceTable.ListColumns("Numéro de facture").DataBodyRange
    Set rSourceDate = SourceTable.ListColumns("Date arrivée courrier").DataBodyRange
    'Debug.Print rSourceFact.Address, rSourceDate.Address
    Set TargetTable = Workbooks("CourrierTS.xlsx").Worksheets("Feuil1").ListObjects("tCourrier")
    Set rTargetFact = TargetTable.ListColumns("NUMERO FACTURES").DataBodyRange
    Set rTargetDate = TargetTable.ListColumns("DATE RETOUR COMPTA").DataBodyRange
    'Debug.Print rTargetFact.Address, rTargetDate.Address
    '--- traiter ligne par ligne
    For SourceRow = 1 To rSourceFact.Rows.Count
        If rSourceDate(SourceRow) <> "" Then
            TargetRow = Application.Match(rSourceFact(SourceRow).Value, rTargetFact, 0)
            'Debug.Print SourceRow, TargetRow, rSourceFact(SourceRow)
            If Not IsError(TargetRow) Then
                'Debug.Print rSourceDate(SourceRow).Value, rTargetDate(TargetRow).Value
                If rTargetDate(TargetRow).Value = "" Then
                    rTargetDate(TargetRow).Value = rSourceDate(SourceRow).Value
                End If
            End If
        End If
    Next SourceRow
    '--- nettoyer
    Set rSourceFact = Nothing
    Set rSourceDate = Nothing
    Set SourceTable = Nothing
    Set rTargetFact = Nothing
    Set rTargetDate = Nothing
    Set TargetTable = Nothing
End Sub

Cordialement.

14/05/2021, 22h02
Pierre Fauconnier

Donc en gros la solution donnée comme première réponse à cette discussion ;)
14/05/2021, 22h17
EricDgn

Exact, juste adaptée.
15/05/2021, 20h54
Pierre Fauconnier

Citation:

Envoyé par EricDgn

Exact, juste adaptée.

Le problème avec le DataBodyRange de ta solution, c'est que si le tableau est vide, la macro plantera. il est important de tester que DataBodyRange n'est pas Nothing. C'est pourquoi je préfère travailler avec la Range("Tableau[Colonne]") comme je l'ai montré dans la première réponse, car ça fonctionne même avec un tableau vide.

De plus, perso, je trouve la syntaxe plus légère et elle évite de passer par des variables en pointant directement vers les objets Excel souhaités.
17/05/2021, 08h58
Thomas_MC

Je vous remercie beaucoup!!

Je viens de tester la solution avec les tableaux structurés...
J'avoue que c'est une fonctionnalité que je ne connais pas du tout mais qui semble intéressante.
Je pensais que juste renommer les plages allait suffire mais apparemment non...

Je teste donc avec la méthode traditionnelle...
J'utilise donc mon fichier de transfert Original et une version courrier "test" (le même mais avec des retours courriers manquants)
La macro, au bout de 7 minutes bug sur la ligne :

Code:

Set rRef2 = rData2.Find(r.Cells(1, 6).Value, , xlValues, xlWhole, xlByColumns) '--- 6 = colonne F

Je vous donne quelques infos au cas où :
Je peux avoir des doublons dans le fichier transfert et plusieurs dates différentes. Dans ce cas, prendre n'importe quelle date au hasard va bien.
J'ai actuellement 2139 lignes dans Transfert et 21175 dans courrier.
Après la ligne 2139, j'ai des "" dans toute la ligne
Le fichier Transfert est plus récent que le fichier courrier (date la plus ancienne en 2018 alors que le transfert commence fin 2020)

Le format texte et nombre m'avait déjà posé une super problème. Les numéro de factures peuvent avoir des formats assez folkloriques (lettres, underscore, tirés, chiffres)
On peut régler le problème du nombre/texte d'une façon? cela fout un sacré foutoir... :oops:
17/05/2021, 09h35
Pierre Fauconnier

Citation:

Envoyé par Thomas_MC

[...]
Je viens de tester la solution avec les tableaux structurés...
J'avoue que c'est une fonctionnalité que je ne connais pas du tout mais qui semble intéressante.[...]
Je teste donc avec la méthode traditionnelle et je vous fais un retour :)

Normalement, lorsqu'on a goûté aux tableaux structurés, on apprécie tellement qu'on ne fait pas marche arrière pour revenir à du code obsolète... :roll:

Citation:

Envoyé par Thomas_MC

[...]
Je vous donne quelques infos au cas où :
Je peux avoir des doublons dans le fichier transfert et plusieurs dates différentes. Dans ce cas, prendre n'importe une date au hasard va bien.
J'ai actuellement 2136 lignes dans Transfert et 21175 dans courrier.

Le format texte et nombre m'avait déjà posé une super problème. Les numéro de factures peuvent avoir des formats assez folkloriques (lettres, underscore, tirés, chiffres)
On peut régler le problème du nombre/texte d'une façon? cela fout un sacré foutoir... :oops:

Dans la mesure où l'on ne sait pas quel code tu utilises ni quelles structures ont tes données, on sait difficilement t'aider au delà de considérations génériques... A ce stade, une copie d'écran et le code utilisé sont de bon aloi.

Si tu utilises les tableaux structurés, je regarderai ton code, sinon, il faudra que tu attendes Eric ou quelqu'un d'autre ;)
17/05/2021, 10h23
Thomas_MC

Merci Pierre! Je veux bien te croire pour cette histoire de tableau structurée 8-)

Je regarde déjà quelle date bug... en regardant la valeur de R ;)
Dans la boucle, je m'amusais à noter la valeur de R dans une cellule...
La valeur de R remonte jusqu'au 14/05/2021, ce qui est la dernière date à ce jour, puis, disparait et quelques secondes plus tard, cela bug...

Ce qui est surprenant, c'est que certaines dates nouvellement inscrites dans le courrier sont par exemple au 30/06/2021... alors qu'évidement, le 14 mai serait la dernière possible.
28/05/2021, 08h28
Thomas_MC

Tout est réglé grâce à vous, cela fonctionne parfaitement!
Merci BEAUCOUP!
:D:D:D