Macro pour aller chercher des données dans un autre fichier

**Philippe Tulliez** · 21/01/2015, 17h12

Bonjour,
Voici une procédure "clé sur porte" qui suppose que les deux classeurs (Source et Cible) sont ouverts et que la première colonne et la première ligne du tableau source soit rempli et pas de cellules fusionnées.
Il suffit de modifier la valeur des constantes se trouvant en début de procédure, renommer la propriété CodeName de la feuille cible par shtData et normalement cela devrait tourner tout seul, à condition d'avoir bien entendu respecter les consignes ci-dessus.

La procédure doit être dans le classeur cible
La liste de données source doit commencer en cellule A1 sinon il faut modifier la ligne de code concernée.

Illustration des deux feuilles sur deux classeurs distincts
Nom : Import By Index_Equiv.jpg
Affichages : 357
Taille : 188,1 Ko

Nom : Import By Index_Equiv.jpg
Affichages : 357
Taille : 188,1 Ko

La formule qui sera insérée dans la plage cible est

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

=INDEX([DataSource.xls]LaSource!$B$2:$E$13;EQUIV($B6;[DataSource.xls]LaSource!$A$2:$A$13;0);EQUIV(C$5;[DataSource.xls]LaSource!$B$1:$E$1;0))

qui donne en VBA

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

=INDEX([DataSource.xls]LaSource!$B$2:$E$13;EQUIV($B6;[DataSource.xls]LaSource!$A$2:$A$13;0);EQUIV(C$5;[DataSource.xls]LaSource!$B$1:$E$1;0))

Le masque de la formule pour permettre d'insérer les références aux cellules d'une façon dynamique est la chaîne de caractère ci-dessous

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

=INDEX(<DataSource>,MATCH(<CelRow>,<Reference>,0),MATCH(<CelCol>,<Label>,0))

Code de la procédure

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
Sub ImportByIndexMatch()
 Const wkbSourceName As String = "DataSource" ' Nom du classeur source
 Const shtSourceName As String = "LaSource"   ' Nom de la feuille source
 Const TargetCell As String = "B5"            ' Adresse de la première cellule du tableau Target
 Dim rngSource As Range, rngSource_Data As Range, rngSource_Ref As Range, rngSource_Label As Range
 Dim rngTarget As Range, rngTarget_Data As Range, rngTarget_Row As Range, rngTarget_Col As Range
 Dim myFormula As String
 myFormula = "=INDEX(<DataSource>,MATCH(<CelRow>,<Reference>,0),MATCH(<CelCol>,<Label>,0))"
 Set rngTarget = shtData.Range(TargetCell).CurrentRegion
 Set rngSource = Workbooks(wkbSourceName).Worksheets(shtSourceName).Range("A1").CurrentRegion
 With rngSource
  Set rngSource_Data = .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1) ' Plage des données
  Set rngSource_Ref = .Offset(1).Resize(.Rows.Count - 1, 1)                      ' 1ère colonne
  Set rngSource_Label = .Offset(columnoffset:=1).Resize(1, .Columns.Count - 1)   ' 1ère ligne
 End With
 With rngTarget
  Set rngTarget_Data = .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1) ' Plage des données
  Set rngTarget_Row = .Offset(RowOffset:=1).Resize(1, 1)                         ' 1ère cellule de la ligne
  Set rngTarget_Col = .Offset(columnoffset:=1).Resize(1, 1)                      ' 1ère cellule de la colonne
 End With
 ' Construction dynamique des références aux cellules dans la formule
 myFormula = Replace(myFormula, "<DataSource>", rngSource_Data.Address(External:=True))
 myFormula = Replace(myFormula, "<CelRow>", rngTarget_Row.Address(RowAbsolute:=False))
 myFormula = Replace(myFormula, "<CelCol>", rngTarget_Col.Address(columnAbsolute:=False))
 myFormula = Replace(myFormula, "<Reference>", rngSource_Ref.Address(External:=True))
 myFormula = Replace(myFormula, "<Label>", rngSource_Label.Address(External:=True))
 ' Importation des données
 With rngTarget_Data
 .Formula = myFormula ' Insérer la formule
 .Value = .Value      ' Remplace les formules par leurs valeurs
 End With
 ' Libère les pointeurs
 Set rngSource = Nothing: Set rngSource_Data = Nothing: Set rngSource_Ref = Nothing: Set rngSource_Label = Nothing
 Set rngTarget = Nothing: Set rngTarget_Data = Nothing: Set rngTarget_Row = Nothing: Set rngTarget_Col = Nothing
End Sub

**Docmarti** · 22/01/2015, 06h22

Bonjour.

Voici une solution qui utilise des tableaux.

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
Sub tt()
 Set wbSource = Workbooks("DataSource.xls")
 
 Set rSource = wbSource.Worksheets("LaSource").Range("C3").CurrentRegion 'Le tableau Source debute en C3
 Set Source_Car = rSource.Cells(1, 2).Resize(1, rSource.Columns.Count - 1)
 Set Source_Ref = rSource.Cells(2, 1).Resize(rSource.Rows.Count - 1, 1)
 
 Set rDest = ThisWorkbook.Worksheets("LaDestination").Range("C6").CurrentRegion 'Le tableau Destination debute en C6
 Set Dest_Car = rDest.Cells(1, 2).Resize(1, rDest.Columns.Count - 1)
 Set Dest_Ref = rDest.Cells(2, 1).Resize(rDest.Rows.Count - 1, 1)
 
 'Rechercher les lignes des REF dans la source
 ReDim tRef(Dest_Ref.Rows.Count)
 
 For i = 1 To Dest_Ref.Rows.Count
  Set result = Source_Ref.Find(what:=Dest_Ref.Cells(i, 1), LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlColumns, searchDirection:=xlNext, SearchFormat:=False)
  tRef(i) = result.Row
 Next
 
 'Rechercher les colonnes des REF dans la source
 ReDim tCar(Dest_Car.Columns.Count)
 
  For i = 1 To Dest_Car.Columns.Count
   Set result = Source_Car.Find(what:=Dest_Car.Cells(1, i), LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlColumns, searchDirection:=xlNext, SearchFormat:=False)
   tCar(i) = result.Column
 Next
 
 rDest.Offset(1, 1).ClearContents 'Effacer les resultats
 
 Dim ValeursDest As Variant 'Declarer un tableau temporaire de type Variant
 
 ValeursDest = rDest.Offset(1, 1).Value 'Dimensionner et remplir le tableau
 
  'Mettre les resultats dans le tableau temporaire.
  For i = 1 To Dest_Ref.Rows.Count
   For j = 1 To Dest_Car.Columns.Count
    ValeursDest(i, j) = rSource.Parent.Cells(tRef(i), tCar(j))
   Next
  Next
 
  rDest.Offset(1, 1).Value = ValeursDest 'Ecrire les resultats
 
End Sub

**GoToon** · 22/01/2015, 10h42

Bonjour et merci pour ces deux propositions.

Je n'ai pas encore essayé la méthode avec Index, j'avais réussi à faire fonctionner la méthode avec les tableaux hier dans la nuit. Je mets tout de même 39 minutes à remplir mon fichier excel... C'est mieux qu'avec ma première macro, mais ça reste long.
Du coup, comme la méthode de Docmarti est plus proche de ce que j'ai fait jusqu'à maintenant, je suis reparti sur cette dernière.
Je ferai après la comparaison avec la méthode de Philippe Tulliez (je ne sais pas laquelle sera la plus rapide... ?)

Quoi qu'il en soit, je rencontre une erreur que je n'explique pas.
Voici le code de Docmarti que j'ai adapté à mon cas :

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 tt()
Dim rSource
Dim Source_Car
Dim Source_Ref
Dim rDest
Dim Dest_Car
Dim Dest_Ref
Dim i As Long, j As Long
Dim result
 
 Workbooks.Open ("Export.xlsx")
 Set wbSource = Workbooks("Export.xlsx")
 Set wbDestination = Workbooks("Outil.xlsm")
 
 Set rSource = wbSource.Worksheets("Export").Range("A1").CurrentRegion 'Le tableau Source debute en A1
 Set Source_Car = rSource.Cells(1, 2).Resize(1, rSource.Columns.Count - 1)
 Set Source_Ref = rSource.Cells(2, 1).Resize(rSource.Rows.Count - 1, 1)
 
 Set rDest = wbDestination.Worksheets("Base").Range("B1").CurrentRegion 'Le tableau Destination debute en B1
 Set Dest_Car = rDest.Cells(1, 2).Resize(1, rDest.Columns.Count - 1)
 Set Dest_Ref = rDest.Cells(2, 1).Resize(rDest.Rows.Count - 1, 1)
 
 'Rechercher les lignes des REF dans la source
 ReDim tRef(Dest_Ref.Rows.Count)
 
 For i = 1 To Dest_Ref.Rows.Count
  Set result = Source_Ref.Find(what:=Dest_Ref.Cells(i, 1), LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlColumns, searchDirection:=xlNext, SearchFormat:=False)
  tRef(i) = result.Row
 Next
 
 'Rechercher les colonnes des REF dans la source
 ReDim tCar(Dest_Car.Columns.Count)
 
  For i = 1 To Dest_Car.Columns.Count
   Set result = Source_Car.Find(what:=Dest_Car.Cells(1, i), LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlColumns, searchDirection:=xlNext, SearchFormat:=False)
   tCar(i) = result.Column
 Next
 
 rDest.Offset(1, 1).ClearContents 'Effacer les resultats
 
 Dim ValeursDest As Variant 'Declarer un tableau temporaire de type Variant
 
 ValeursDest = rDest.Offset(1, 1).Value 'Dimensionner et remplir le tableau
 
  'Mettre les resultats dans le tableau temporaire.
  For i = 1 To Dest_Ref.Rows.Count
   For j = 1 To Dest_Car.Columns.Count
    ValeursDest(i, j) = rSource.Parent.Cells(tRef(i), tCar(j))
   Next
  Next
 
  rDest.Offset(1, 1).Value = ValeursDest 'Ecrire les resultats
 
End Sub

J'ai fait des déclarations dans tous les sens car Excel plantait sinon...
Le problème, c'est qu'il me fait une erreur sur la ligne 28 : "Erreur d'exécution '91' : Variable objet ou variable de bloc With non définie"

Une idée ?

Merci !

**Nico Chg** · 22/01/2015, 11h15

Bonjour,

Premier constat : Essaie de typer tes variables, et pas de les déclarer en Variant (c'est un Variant implicite), le programme sera plus clair dans ce cas.

Ensuite, tu n'as pas typer ta variable result, et tu lui assigne une propriété .row. Peut être que par défaut result se set en Range, mais si le find ne trouve rien, comment se comporte result ?

**GoToon** · 22/01/2015, 11h22

En fait, c'est un peu le souci, je ne sais pas comment les typer... Je vois que rSource et rDest sont des Range, mais le reste ??

Désolé, ça se voit que je suis un peu au-delà de ce que je comprend vraiment ???

[Edit: C'est bien le result qui bloque. Il est à Nothing et c'est ça qui fait planter le tout... Je suis un peu bloqué là, j'avoue...]

**Docmarti** · 22/01/2015, 12h06

Envoyé par GoToon

Le problème, c'est qu'il me fait une erreur sur la ligne 28 : "Erreur d'exécution '91' : Variable objet ou variable de bloc With non définie"

Tu dois avoir un Ref de la feuille Base qui n'est pas trouvé sur la feuille Export.

Vérifie avec ceci:

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
55
56
57
58
59
60
61
62
63
64
65
66
67
Sub TT_2()
Dim rSource
Dim Source_Car
Dim Source_Ref
Dim rDest
Dim Dest_Car
Dim Dest_Ref
Dim i As Long, j As Long
Dim result
 
 Workbooks.Open ("Export.xlsx")
 
 Set wbSource = Workbooks("Export.xlsx")
 Set wbDestination = Workbooks("Outil.xlsm")
 
 Set rSource = wbSource.Worksheets("Export").Range("A1").CurrentRegion 'Le tableau Source debute en A1
 Set Source_Car = rSource.Cells(1, 2).Resize(1, rSource.Columns.Count - 1)
 Set Source_Ref = rSource.Cells(2, 1).Resize(rSource.Rows.Count - 1, 1)
 
 Set rDest = wbDestination.Worksheets("Base").Range("B1").CurrentRegion 'Le tableau Destination debute en B1
 Set Dest_Car = rDest.Cells(1, 2).Resize(1, rDest.Columns.Count - 1)
 Set Dest_Ref = rDest.Cells(2, 1).Resize(rDest.Rows.Count - 1, 1)
 
 'Rechercher les lignes des REF dans la source
 ReDim tRef(Dest_Ref.Rows.Count)
 
 For i = 1 To Dest_Ref.Rows.Count
  Set result = Source_Ref.Find(what:=Dest_Ref.Cells(i, 1), LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlColumns, searchDirection:=xlNext, SearchFormat:=False)
  If result Is Nothing Then
 
    MsgBoxDest_Ref.Cells(i, 1), , "Non trouvé" '[ Edit:]
 
    Exit Sub
   Else
    tRef(i) = result.Row
  End If
 Next
 
 'Rechercher les colonnes des REF dans la source
 ReDim tCar(Dest_Car.Columns.Count)
 
  For i = 1 To Dest_Car.Columns.Count
   Set result = Source_Car.Find(what:=Dest_Car.Cells(1, i), LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlColumns, searchDirection:=xlNext, SearchFormat:=False)
   If result Is Nothing Then
    MsgBox Dest_Car.Cells(1, i), , "Non trouvé"
    Exit Sub
   Else
    tCar(i) = result.Column
   End If
 Next
 
 rDest.Offset(1, 1).ClearContents 'Effacer les resultats
 
 Dim ValeursDest As Variant 'Declarer un tableau temporaire de type Variant
 
 ValeursDest = rDest.Offset(1, 1).Value 'Dimensionner et remplir le tableau
 
  'Mettre les resultats dans le tableau temporaire.
  For i = 1 To Dest_Ref.Rows.Count
   For j = 1 To Dest_Car.Columns.Count
    ValeursDest(i, j) = rSource.Parent.Cells(tRef(i), tCar(j))
   Next
  Next
 
  rDest.Offset(1, 1).Value = ValeursDest 'Ecrire les resultats
 
End Sub

**GoToon** · 22/01/2015, 13h09

Oui c'est bien ça le problème.
J'ai en effet la possibilité (plus que probable) d'avoir de Ref qui ne figurent pas dans mon fichier source. A ce moment là, il faudrait que je lui dise de laisser vides les cellules Carac associées à cette Ref.
Pour pallier à ça, j'ai remplacé

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
    MsgBox Dest_Car.Cells(1, i), , "Non trouvé"
    Exit Sub

par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

tCar(i) = 10000

que je sais être vide. La macro est allée jusqu'au bout, mais mon fichier destination reste immuablement vide.
J'ai l'impression que mon result est toujours Nothing... Je vais essayer de tester pour voir si ça vient de là.

[Edit: Rôôô le boulet, en faisant mes essais, je ne m'étais pas rendu compte que j'avais supprimé toutes mes références en colonne B...]

J'ai du coup une erreur d'exécution '1004' Erreur définie par l'application ou par l'objet sur la ligne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

    ValeursDest(i, j) = rSource.Parent.Cells(tRef(i), tCar(j))

**Philippe Tulliez** · 22/01/2015, 13h57

Bonjour,
Juste au cas où tu testerais la procédure proposée http://www.developpez.net/forums/d14...r/#post8105477
Ligne à remplacer ligne 8 (Ne fonctionne que pour les versions supérieures à Excel 2003.
Place une chaîne vide si les données ne sont pas trouvées

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

myFormula = "=IFERROR(INDEX(<DataSource>,MATCH(<CelRow>,<Reference>,0),MATCH(<CelCol>,<Label>,0))," & Chr(34) & Chr(34) & ")"

ou si l'on préfère avoir le texte "Pas trouvé"

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

myFormula = "=IFERROR(INDEX(<DataSource>,MATCH(<CelRow>,<Reference>,0),MATCH(<CelCol>,<Label>,0))," & Chr(34) & "Pas trouvé" & Chr(34) & ")"

**GoToon** · 22/01/2015, 14h37

Je pense que je vais bientôt la tester car je suis confronté à un souci avec la solution "Tableau".
Un truc que je n'avais pas anticipé (ENORME mea culpa) est que mon fichier Destination contient des données qui ne sont pas dans mon fichier source. Par exemple, une colonne spécifiant si la référence a été vendue en chine ou non (il y en a des dizaine d'autre...). Cette donnée n’apparaît pas dans mon fichier source et n'y sera jamais. Pourtant je souhaite la conserver dans mon fichier destination.
Je ne suis pas sûr que ma macro Tableau puisse gérer ça...

Je suis en train de tester la formule par IndexMatch de Philippe Tulliez, mais j'ai quelques soucis :
ligne 9 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set rngTarget = shtData.Range(TargetCell).CurrentRegion

qu'est-ce que shtData ?

**Docmarti** · 22/01/2015, 16h19

Envoyé par GoToon

Pour pallier à ça, j'ai remplacé

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
MsgBox Dest_Car.Cells(1, i), , "Non trouvé"
    Exit Sub

par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

tCar(i) = 10000

J'ai du coup une erreur d'exécution '1004' Erreur définie par l'application ou par l'objet [/CODE]

Tu serais mieux de par remplacer par rien du tout.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

tCar(i) = ""

Pour ensuite faire le test suivant:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
If tRef(i) = "" Or tCar(j) = "" Then
      ValeursDest(i, j) = ""
    Else
     ValeursDest(i, j) = rSource.Parent.Cells(tRef(i), tCar(j))
    End If

Si tu as des lignes que tu veux conserver parce qu'une caractéristique contient Chine, supprime

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

rDest.Offset(1, 1).ClearContents

afin de conserver les valeurs originales dans le tableau.
Puis teste si Chine s'y trouve. Ca va donner ceci:

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
For i = 1 To Dest_Ref.Rows.Count
 
   For j = 1 To Dest_Car.Columns.Count
 
   'Chine
   If Trim(rDest.Offset(i, 3).Cells(1, 1)) Like "Chine" Then Exit For
   'Vietnam
   If rDest.Offset(i, 3).Cells(1, 1) Like "Vietnam" Then Exit For
 
   If tRef(i) = "" Or tCar(j) = "" Then
      ValeursDest(i, j) = ""
    Else
     ValeursDest(i, j) = rSource.Parent.Cells(tRef(i), tCar(j))
    End If
   Next
  Next

Tout 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
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
Option Explicit
Sub TT_4()
 
Dim xx As Variant
 
Dim rSource As Range
Dim Source_Car As Range
Dim Source_Ref As Range
Dim rDest As Range
Dim Dest_Car As Range
Dim Dest_Ref As Range
Dim i As Long, j As Long
 
 Dim wbSource As Workbook
 Dim wbDestination As Workbook
 
 'Workbooks.Open ("Export.xlsx")
 
 Set wbSource = Workbooks("Export.xlsx")
 Set wbDestination = Workbooks("Outil.xlsm")
 
 Set rSource = wbSource.Worksheets("Export").Range("A1").CurrentRegion 'Le tableau Source debute en A1
 Set Source_Car = rSource.Cells(1, 2).Resize(1, rSource.Columns.Count - 1)
 Set Source_Ref = rSource.Cells(2, 1).Resize(rSource.Rows.Count - 1, 1)
 
 Set rDest = wbDestination.Worksheets("Base").Range("B1").CurrentRegion 'Le tableau Destination debute en B1
 Set Dest_Car = rDest.Cells(1, 2).Resize(1, rDest.Columns.Count - 1)
 Set Dest_Ref = rDest.Cells(2, 1).Resize(rDest.Rows.Count - 1, 1)
 
 'Rechercher les lignes des REF dans la source
 ReDim tRef(Dest_Ref.Rows.Count)
 
 For i = 1 To Dest_Ref.Rows.Count
 
  xx = Application.Match(Dest_Ref.Cells(i, 1).Value, Source_Ref, 0)
 
 If Not IsError(xx) Then
  tRef(i) = Source_Ref.Cells(xx).Row
  Else
   tRef(i) = ""
  End If
 Next
 
 'Rechercher les colonnes des REF dans la source
 ReDim tCar(Dest_Car.Columns.Count)
 
  For i = 1 To Dest_Car.Columns.Count
 
   xx = Application.Match(Dest_Car.Cells(1, i).Value, Source_Car, 0)
  If Not IsError(xx) Then
   tCar(i) = Source_Car.Cells(xx).Column
  Else
   tCar(i) = ""
  End If
 Next
 
 'rDest.Offset(1, 1).ClearContents 'Effacer les resultats
 
 Dim ValeursDest As Variant 'Declarer un tableau temporaire de type Variant
 
 ValeursDest = rDest.Offset(1, 1).Value 'Dimensionner et remplir le tableau
 
  'Mettre les resultats dans le tableau temporaire.
  For i = 1 To Dest_Ref.Rows.Count
 
   For j = 1 To Dest_Car.Columns.Count
 
   'Chine
   If Trim(rDest.Offset(i, 3).Cells(1, 1)) Like "Chine" Then Exit For
   'Vietnam
   If Trim(rDest.Offset(i, 3).Cells(1, 1)) Like "Vietnam" Then Exit For
 
   If tRef(i) = "" Or tCar(j) = "" Then
      ValeursDest(i, j) = ""
    Else
     ValeursDest(i, j) = rSource.Parent.Cells(tRef(i), tCar(j))
    End If
   Next
  Next
 
  rDest.Offset(1, 1).Value = ValeursDest 'Ecrire les resultats
 
  MsgBox "Terminé"
 
End Sub

**Philippe Tulliez** · 22/01/2015, 16h33

Bonjour,

Je suis en train de tester la formule par IndexMatch de Philippe Tulliez, mais j'ai quelques soucis :
ligne 9 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set rngTarget = shtData.Range(TargetCell).CurrentRegion

qu'est-ce que shtData ?

C'est le CodeName de la feuille
Tout est expliqué dans ma réponse (fil #24) http://www.developpez.net/forums/d14...r/#post8105477

Il suffit de modifier la valeur des constantes se trouvant en début de procédure, renommer la propriété CodeName de la feuille cible par shtData et normalement cela devrait tourner tout seul, à condition d'avoir bien entendu respecter les consignes ci-dessus.

Tu peux également remplacer cette ligne par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 Set rngTarget = ThisWorkbook.Worksheets("Data").Range(TargetCell).CurrentRegion

Il faut alors remplacer la constante Data par le nom de ta feuille cible.
L'avantage d'utiliser le CodeName d'une feuille, c'est qu'il n'y aura aucun problème si l'utilisateur renomme la feuille.

**GoToon** · 22/01/2015, 22h21

Donc, je viens de faire les modifs selon ce que tu m'as dit Docmarti et tout semble marcher concernant mes données (c'est génial !!!)

Par contre, j'ai toujours ce problème de données qui sont déjà dans Destination mais pas dans Source et que je veux conserver qui disparaissent.

En gros :

les REF qui ne sont pas dans Source disparaissent
le contenu des CARAC absentes de Source disparait. Exemple : CARAC Chine qui contient des "Oui" et des "Non" : l'intitulé de colonne "Chine" est conservé dans Destination, mais le contenu de cette colonne (tous les "Oui" et les "Non") disparait

J'ai modifié ton code car j'avais des soucis au niveau des premières lignes premières colonnes à prendre en compte dans mes fichiers (le prob vient peut-être de là). Voilà ce que ça donne :

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
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
Sub TT4()
Dim rSource As Range
Dim Source_Car As Range
Dim Source_Ref As Range
Dim rDest As Range
Dim Dest_Car As Range
Dim Dest_Ref As Range
Dim i As Long, j As Long
Dim result As Range
Dim xx As Variant
 
 'Workbooks.Open ("Export.xlsx")
 Set wbSource = Workbooks("Export.xlsx")
 Set wbDestination = Workbooks("Outil.xlsm")
 
 Set rSource = wbSource.Worksheets("Export").Range("A1").CurrentRegion 'Le tableau Source debute en A1
 Set Source_Car = rSource.Cells(1, 1).Resize(1, rSource.Columns.Count - 1)
 Set Source_Ref = rSource.Cells(2, 1).Resize(rSource.Rows.Count - 1, 1)
 
 Set rDest = wbDestination.Worksheets("Base").Range("B1").CurrentRegion 'Le tableau Destination debute en B1
 Set Dest_Car = rDest.Cells(1, 2).Resize(1, rDest.Columns.Count - 1)
 Set Dest_Ref = rDest.Cells(2, 1).Resize(rDest.Rows.Count - 1, 1)
 
 'Rechercher les lignes des REF dans la source
 ReDim tRef(Dest_Ref.Rows.Count)
 
 For i = 1 To Dest_Ref.Rows.Count
 xx = Application.Match(Dest_Ref.Cells(i, 2).Value, Source_Ref, 0)
 Application.StatusBar = "Ligne " & i
 If Not IsError(xx) Then
  tRef(i) = Source_Ref.Cells(xx).Row
  Else
   tRef(i) = ""
  End If
 Next
 
 'Rechercher les colonnes des CAR dans la source
 ReDim tCar(Dest_Car.Columns.Count)
 
  For i = 1 To Dest_Car.Columns.Count
 Application.StatusBar = "Colonne " & i
   xx = Application.Match(Dest_Car.Cells(1, i).Value, Source_Car, 0)
  If Not IsError(xx) Then
   tCar(i) = Source_Car.Cells(xx).Column
  Else
   tCar(i) = ""
  End If
 Next
 
 'rDest.Offset(1, 1).ClearContents 'Effacer les resultats
 
 Dim ValeursDest As Variant 'Declarer un tableau temporaire de type Variant
 
 ValeursDest = rDest.Offset(1, 1).Value 'Dimensionner et remplir le tableau
 
  'Mettre les resultats dans le tableau temporaire.
  For i = 1 To Dest_Ref.Rows.Count
   For j = 1 To Dest_Car.Columns.Count
    If Trim(rDest.Offset(i, 3).Cells(1, 1)) Like "Chine" Then Exit For
    If tRef(i) = "" Or tCar(j) = "" Then
      ValeursDest(i, j) = ""
    Else
     ValeursDest(i, j) = rSource.Parent.Cells(tRef(i), tCar(j))
    End If
   Next
  Next
 
  rDest.Offset(1, 1).Value = ValeursDest 'Ecrire les resultats
 
 MsgBox "Terminé"
 
End Sub

Autant pour moi Philippe Tulliez

, je teste et je reviens

Alors, je ne suis pas sûr de moi, mais au final, j'aimerai déclarer deux autres tableaux qui iraient stocker les adresses des cellules de Destination.
En gros, j'ai modifié ça :

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
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
Sub TT4()
Dim rSource As Range
Dim Source_Car As Range
Dim Source_Ref As Range
Dim rDest As Range
Dim Dest_Car As Range
Dim Dest_Ref As Range
Dim i As Long, j As Long
Dim result As Range
Dim xx As Variant
 
 'Workbooks.Open ("Export.xlsx")
 Set wbSource = Workbooks("Export.xlsx")
 Set wbDestination = Workbooks("Outil.xlsm")
 
 Set rSource = wbSource.Worksheets("Export").Range("A1").CurrentRegion 'Le tableau Source debute en A1
 Set Source_Car = rSource.Cells(1, 1).Resize(1, rSource.Columns.Count - 1)
 Set Source_Ref = rSource.Cells(2, 1).Resize(rSource.Rows.Count - 1, 1)
 
 Set rDest = wbDestination.Worksheets("Base").Range("B1").CurrentRegion 'Le tableau Destination debute en B1
 Set Dest_Car = rDest.Cells(1, 2).Resize(1, rDest.Columns.Count - 1)
 Set Dest_Ref = rDest.Cells(2, 1).Resize(rDest.Rows.Count - 1, 1)
 
 'Rechercher les lignes des REF dans la source
 ReDim tRef(Dest_Ref.Rows.Count)
 ReDim tRefDest(Dest_Ref.Rows.Count)
 
 For i = 1 To Dest_Ref.Rows.Count
 xx = Application.Match(Dest_Ref.Cells(i, 2).Value, Source_Ref, 0)
 Application.StatusBar = "Ligne " & i
 If Not IsError(xx) Then
  tRef(i) = Source_Ref.Cells(xx).Row
  tRefDest(i) = ""
  Else
   tRefDest(i) = Dest_Ref.Cells(i, 2).Row
   tRef(i) = ""
  End If
 Next
 
 'Rechercher les colonnes des CAR dans la source
 ReDim tCar(Dest_Car.Columns.Count)
 ReDim tCarDest(Dest_Car.Columns.Count)
 
  For i = 1 To Dest_Car.Columns.Count
 Application.StatusBar = "Colonne " & i
   xx = Application.Match(Dest_Car.Cells(1, i).Value, Source_Car, 0)
  If Not IsError(xx) Then
   tCar(i) = Source_Car.Cells(xx).Column
   tCarDest(i) = ""
  Else
   tCar(i) = ""
   tCarDest(i) = Dest_Car.Cells(1, i).Column
  End If
 Next
 
 'rDest.Offset(1, 1).ClearContents 'Effacer les resultats
 
 Dim ValeursDest As Variant 'Declarer un tableau temporaire de type Variant
 
 ValeursDest = rDest.Offset(1, 1).Value 'Dimensionner et remplir le tableau
 
  'Mettre les resultats dans le tableau temporaire.
  For i = 1 To Dest_Ref.Rows.Count
   For j = 1 To Dest_Car.Columns.Count
    If Trim(rDest.Offset(i, 3).Cells(1, 1)) Like "Chine" Then Exit For
    If tRef(i) = ""  Or tCar(j) = "" Then
      ValeursDest(i, j) = rDest.Parent.Cells(tRefDest(i), tCarDest(j))
    Else
     ValeursDest(i, j) = rSource.Parent.Cells(tRef(i), tCar(j))
    End If
   Next
  Next
 
  rDest.Offset(1, 1).Value = ValeursDest 'Ecrire les resultats
 
 MsgBox "Terminé"
 
End Sub

Mais j'ai une "Erreur d'exécution '13': incompatibilité de type".
On n'est pas loin du but, là non ???

**Docmarti** · 22/01/2015, 23h13

Bonjour GoToon

Tu as modifié

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 Set Source_Car = rSource.Cells(1, 2).Resize(1, rSource.Columns.Count - 1)

en

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 Set Source_Car = rSource.Cells(1, 1).Resize(1, rSource.Columns.Count - 1)

Je n'en vois pas la raison.

**GoToon** · 22/01/2015, 23h34

Parce que mes intitulés de caractéristiques commencent en colonne 1 et non en colonne 2 (le premier intitulé est "RefProduit" et contient les Ref ?
Si je mets 2, je perds mes Références : tout le contenu de la colonne 1 disparait. Si je met 1, je conserve les Références de produits en colonne 1, sauf les références qui n'apparaissent pas dans Source, qui elles, disparaissent.
Je peux peut-être te donner les fichiers réels afin que tu vois ce que ça donne ?

**Docmarti** · 23/01/2015, 00h29

Envoyé par GoToon

Je peux peut-être te donner les fichiers réels afin que tu vois ce que ça donne ?

Oui, avec quelques lignes de données anonymisées si nécessaire. Ce serait bien.

**GoToon** · 23/01/2015, 14h59

@Philippe Tulliez : J'ai finalisé la macro selon ta méthode. Elle est en effet beaucoup plus rapide que mon précédent RechercheV, mais elle reste un peu trop gourmande au final. Tout simplement car ça n'est pas un simple INDEX(XXX;EQUIV();EQUIV()), mais un :
SIERREUR(INDEX(XXX;EQUIV();EQUIV());SI(INDEX(YYY;EQUIV();EQUIV())="";"";INDEX(YYY;EQUIV();EQUIV()))
J'ai dû initialiser une copie de ma feuille cible en début de macro, et aller chercher la valeur dedans en cas d'erreur sur le premier INDEX. Au moins, je suis sûr de ne pas perdre de données dans ce cas. C'est toujours à cause de mon histoire de vouloir conserver certaines données déjà présentes dans la feuille cible mais absentes de la feuille source...

Au final, je conserve cette version pour le moment qui a le mérite d'être fonctionnelle, en attendant des nouvelles de Docmarti pour voir si la solution des tableaux est plus rapide. Je ne ferme donc pas le sujet qui n'est pas tout à fait résolu.
En tous cas, encore merci Philippe !!!!

[Edit : Après plusieurs tests, cette macro ne conviendra finalement pas non plus : elle fait planter Excel. Pas assez de ressources visiblement : j'ai des messages Excel transparents, avec des boutons transparents qui apparaissent de partout au bout d'une trentaine de secondes... En gros, la macro marche sur environ 6000 lignes par 300 colonnes, mais si je mets les 600 colonnes, là, ça plante... je vais tout de même la conserver dans un coin, elle pourra servir lorsque je n'aurai que quelques références à récupérer dans mon fichier cible.]

**Docmarti** · 23/01/2015, 17h46

Bonjour GoToon

Le code fonctionne avec ta modification précédente.

Par contre tRefDest tCarDest ne me semblent pas être utiles.
ValeursDest(i, j) = rDest.Parent.Cells(tRefDest(i), tCarDest(j)) 'Inutile car ca ne change pas la valeur

**GoToon** · 23/01/2015, 18h19

Tu es mon dieu..........
Même si j'avoue ne pas me souvenir réellement du pourquoi j'avais fait cette modification...
Bref, encore merci pour tout le temps que vous aurez bien voulu tous m'accorder !!!!!! Et un remerciement encore plus grand à toi Docmarti !!!!

Moralité : quand tu ne sais pas vraiment coder, abstiens-toi de coder la nuit !!!

**Docmarti** · 23/01/2015, 21h21

Je n'avais pas vu ton deuxième MP.

Ta modification fonctionne. Mais ca ne concerne pas les colonnes ToPrint et Chine sur lesquelles je ne me suis pas penché. Je ne sais pas exactement ce que tu souhaites avec ces 2 colonnes.

**GoToon** · 23/01/2015, 22h15

Euh, tu veux dire que j'ai réussi à faire fonctionner la macro en suivant tes indications du dernier post qui n'en étaient pas...
Lol. Enfin dans tous les cas, c'est toi qui m'a permis de comprendre comment faire ça.
Un grand merci a tous ceux qui m'ont aidé sur ce sujet et un merci tout particulier a Docmarti
Au passage : 53 secondes pour remplir 6347 lignes sur 547 colonnes. La classe absolue.
Merci !!!

Macro pour aller chercher des données dans un autre fichier [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager