> Tous les forums > Forum Bureautique
 Excel 2010 VBA synthese 2 classeursSujet résolu
Ajouter un message à la discussion
Page : [1] 
Page 1 sur 1
WINNIE0931
  Posté le 07/01/2016 @ 10:16 
Aller en bas de la page 
Petit astucien

Bonjour à tous.

je suis amené régulièrement à croiser deux sources de données différentes sous excel.

Une clé primaire identique est présente dans les 2 classeurs.

Plutôt que de passer par index équiv, j'ai développé une macro (en fichier joint) qui permet (via des inputbox) et au sein d'un même classeur, de choisir les données à récupérer du fichier 2 , et de les déposer dans le fichier de synthèse qui est une copie du fichier 1

Le code utilise l'instruction "Application.Match"

Problème, la procédure ne fonctionne que pour la 1ère occurrence trouvée.

les autres lignes qui contiennent les mêmes données dans les 2 classeurs restent vides

Je joins le classeur xlsm à titre d'exemple.

classeur

l'onglet "source" est le fichier 1

l'onglet "table" est le fichier 2 et contient la donnée à récupérer

l'onglet "recap" est à la base une copie du fichier 1 dans laquelle va être déposée la donnée à récupérer

la macro se lance avec le bouton de l'onglet "recap"

Qu'en pensez vous ?

Je vous remercie de votre aide

Publicité
WINNIE0931
 Posté le 07/01/2016 à 10:29 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Petit astucien

Bonjour,

Apparemment le lien ne fonctionne pas pour télécharger le fichier xlsm

je joins donc un nouveau lien vers un simple fichier xlsx

xlsx

Voici le code utilisé ci dessous à coller dans un module.

Avec toutes mes excuses.

Sub syntheseclasseur()


'il est obligatoire d'avoir dupliquer la feuille à compléter dans un onglet "recap"
If MsgBox("l'onglet à compléter a t-il été copié et nommé recap ?", vbYesNo, "") = vbNo Then 'si la réponse est non on sort de la macro
Exit Sub
End If

If MsgBox("le classeur qui contient les données à récupérer est-il en onglet 2 ?", vbYesNo, "") = vbNo Then 'si la réponse est non on sort de la macro
Exit Sub
End If

'MsgBox ("La clé primaire doit toujours être en colonne A dans les 2 fichiers")
If MsgBox("La clé primaire est-elle en colonne A dans les 2 fichiers ?", vbYesNo, "") = vbNo Then 'si la réponse est non on sort de la macro
Exit Sub
End If


name1 = Sheets(1).Name
name2 = Sheets(2).Name

Set onglet1 = Sheets(name1)
Set onglet2 = Sheets(name2)

Application.ReferenceStyle = xlR1C1 'affichage en numéro de colonne pour identifier la colonne qui contient la donnée à récupérer et la colonne où déposer cette donnée dans le fichier recap

Sheets(name2).Select
numcolfich2recup = Application.InputBox("Saisir le numéro de la colonne à récupérer du fichier 2", , 2, Type:=1) 'permet de saisir le numéro de la colonne qui contient la donnée à récupérer du fichier 2
If VarType(numcolfich2recup) = vbBoolean Then MsgBox "Abandon !": Exit Sub


Sheets("recap").Select


numcolfichrecap = Application.InputBox("Saisir le numéro de la colonne où déposer les données", , 4, Type:=1) 'permet de saisir le numéro de la colonne qui va réceptionner les données du fichier 2
If VarType(numcolfichrecap) = vbBoolean Then MsgBox "Abandon !": Exit Sub




For Each c In Range(onglet2.[A2], onglet2.[a65000].End(xlUp))
p = Application.Match(c, [A:A], 0)
If IsError(p) Then
[a65000].End(xlUp).Offset(1, 0) = ""

Else
[A1].Offset(p - 1, numcolfichrecap - 1) = c.Offset(0, numcolfich2recup - 1)


End If

Next c

Sheets(name2).Select

Cells(1, numcolfich2recup).Copy 'copie de l'en tête de colonne de la donnée récupérée du fichier 2

Sheets("recap").Select

Cells(1, numcolfichrecap).Select 'colle l'en tête de colonne de la donnée récupérée dans le fichier recap
ActiveSheet.Paste

Application.ReferenceStyle = xlA1 'on repasse en affichage lettre colonne

End Sub



Modifié par WINNIE0931 le 07/01/2016 10:35
gilbert_rgi
 Posté le 07/01/2016 à 14:13 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Astucien

Bonjour,

le lien fonctionne très bien mais il s'ouvre avec IE ou Firefox une fois ouvert l'enregistrer sous : votre disque dur

ensuite ouvrir ce fichier avec excel et voilà ça fonctionne

c'est le problème des xlsm sur cjoint

salutations

gilbert_rgi
 Posté le 07/01/2016 à 14:41 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Astucien

le résultat est normal

pour voir votre erreur ajoutez les lignes en rouge et voir les valeurs dans la fenêtre execution

For Each c In Range(onglet2.[A2], onglet2.[a65000].End(xlUp))
p = Application.Match(c, [A:A], 0)
If IsError(p) Then
[a65000].End(xlUp).Offset(1, 0) = ""

Else
Debug.Print numcolfichrecap
Debug.Print numcolfich2recup
Debug.Print p
[A1].Offset(p - 1, numcolfichrecap - 1) = c.Offset(0, numcolfich2recup - 1)


End If

Next c

WINNIE0931
 Posté le 07/01/2016 à 14:46 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Petit astucien
gilbert_rgi a écrit :

Bonjour,

le lien fonctionne très bien mais il s'ouvre avec IE ou Firefox une fois ouvert l'enregistrer sous : votre disque dur

ensuite ouvrir ce fichier avec excel et voilà ça fonctionne

c'est le problème des xlsm sur cjoint

salutations

Bonjour et merci de cette information.

Bonne soirée.

WINNIE0931
 Posté le 07/01/2016 à 14:55 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Petit astucien

Bonjour et pardon gilbert_rgi

Je n'avais pas vu votre réponse.

J'ai rajouté les lignes en rouge dans la procédure.

Debug.Print numcolfichrecap
Debug.Print numcolfich2recup
Debug.Print p

Au niveau de la fenêtre exécution, est ce la fenêtre que l'on voit apparaitre par (Crl+G) ?

Je vois effectivement des chiffres défiler mais je ne sais pas les les interpréter

Pouvez vous m'éclairer ?

Un grand merci.



Modifié par WINNIE0931 le 07/01/2016 15:04
gilbert_rgi
 Posté le 07/01/2016 à 15:44 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Astucien

bon voilà après quels essais je pense que c'est ça

et la fenêtre d'execution c'est bien la fenêtre ctrl +G

en mode pas à pas on peut voir à quoi ça correspond très utile pour le débogage ;-)))

Sub syntheseclasseur()


'il est obligatoire d'avoir dupliquer la feuille à compléter dans un onglet "recap"
If MsgBox("l'onglet à compléter a t-il été copié et nommé recap ?", vbYesNo, "") = vbNo Then 'si la réponse est non on sort de la macro
Exit Sub
End If

If MsgBox("le classeur qui contient les données à récupérer est-il en onglet 2 ?", vbYesNo, "") = vbNo Then 'si la réponse est non on sort de la macro
Exit Sub
End If

'MsgBox ("La clé primaire doit toujours être en colonne A dans les 2 fichiers")
If MsgBox("La clé primaire est-elle en colonne A dans les 2 fichiers ?", vbYesNo, "") = vbNo Then 'si la réponse est non on sort de la macro
Exit Sub
End If


name1 = Sheets(1).Name
name2 = Sheets(2).Name

Set onglet1 = Sheets(name1)
Set onglet2 = Sheets(name2)

Application.ReferenceStyle = xlR1C1 'affichage en numéro de colonne pour identifier la colonne qui contient la donnée à récupérer et la colonne où déposer cette donnée dans le fichier recap

Sheets(name2).Select
numcolfich2recup = Application.InputBox("Saisir le numéro de la colonne à récupérer du fichier 2", , 2, Type:=1) 'permet de saisir le numéro de la colonne qui contient la donnée à récupérer du fichier 2
If VarType(numcolfich2recup) = vbBoolean Then MsgBox "Abandon !": Exit Sub
Application.ScreenUpdating = False

Sheets("recap").Select


numcolfichrecap = Application.InputBox("Saisir le numéro de la colonne où déposer les données", , 4, Type:=1) 'permet de saisir le numéro de la colonne qui va réceptionner les données du fichier 2
If VarType(numcolfichrecap) = vbBoolean Then MsgBox "Abandon !": Exit Sub




For Each c In Range(onglet2.[A2], onglet2.[a65000].End(xlUp))
p = Application.Match(c, [A:A], 0)
a = 0
For lig = p To onglet1.[a65000].End(xlUp).Row
If IsError(p) Then
[a65000].End(xlUp).Offset(1, 0) = ""

Else
' Debug.Print numcolfichrecap
' Debug.Print numcolfich2recup
' Debug.Print p + a
[A1].Offset((p + a) - 1, numcolfichrecap - 1) = c.Offset(0, numcolfich2recup - 1)
End If
' Debug.Print c
' Debug.Print onglet1.Cells((p + a), 1)
If c <> onglet1.Cells((p + a), 1).Value Then GoTo suite
a = a + 1
Next
suite:
Next c
Application.ScreenUpdating = True
Sheets(name2).Select

Cells(1, numcolfich2recup).Copy 'copie de l'en tête de colonne de la donnée récupérée du fichier 2

Sheets("recap").Select

Cells(1, numcolfichrecap).Select 'colle l'en tête de colonne de la donnée récupérée dans le fichier recap
ActiveSheet.Paste

Application.ReferenceStyle = xlA1 'on repasse en affichage lettre colonne

End Sub

WINNIE0931
 Posté le 07/01/2016 à 16:08 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Petit astucien

Un grand merci Gilbert_RGI!

Par contre puis je abuser de ta gentillesse en évoquant une dernière question ?

Si par hasard une ligne du fichier 1 n'a pas de correspondance avec le fichier 2 (différence de clé primaire), est ce possible d'avoir une valeur vide dans la colonne correspondante du fichier recap

J'ai fait l'expérience en rentrant une clé fantaisiste qui n'existe pas dans l'onglet "table" mais la macro me ramène une valeur alors que la cellule devrait être vide .

(ligne 12 et 28 en jaune du fichier recap dans le classeur joint)

classeur xlsx modifié

Qu'en penses tu ?

Encore une fois je t'adresse mes remerciements .

gilbert_rgi
 Posté le 07/01/2016 à 16:55 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Astucien

excusez moi du contre temps "pause café" ;-)))

alors voilà

http://www.cjoint.com/c/FAhp25UVLUz

Publicité
gilbert_rgi
 Posté le 07/01/2016 à 17:14 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Astucien

pour le fun en couleur quand erreur ;-)))

For Each c In Range(onglet2.[A2], onglet2.[a65000].End(xlUp))
p = Application.Match(c, [A:A], 0)
a = 0
For lig = p To onglet1.[a65000].End(xlUp).Row
If IsError(p) Then
[a65000].End(xlUp).Offset(1, 0) = ""

Else
' Debug.Print [A1].Offset((p + a) - 1, 0)
If [A1].Offset((p + a) - 1, 0) = c Then
[A1].Offset((p + a) - 1, numcolfichrecap - 1) = c.Offset(0, numcolfich2recup - 1)
[A1].Offset((p + a) - 1, 1).EntireRow.Interior.Color = RGB(255, 255, 255)

Else
[A1].Offset((p + a) - 1, numcolfichrecap - 1) = "Erreur"
[A1].Offset((p + a) - 1, 1).EntireRow.Interior.Color = RGB(255, 255, 0)
End If
End If
If c <> onglet1.Cells((p + a), 1).Value Then GoTo suite
a = a + 1
Next
suite:
Next c

WINNIE0931
 Posté le 07/01/2016 à 18:35 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Petit astucien

alors là chapeau !

C'est super.

Je vous remercie de votre disponibilité et de votre gentillesse.

attention à la pause café mais vous l'avez tellement méritée !

par contre je vais creuser du côté des fenêtres "exécution" pour tester les procédures futures

Bonne soirée et encore merci !



Modifié par WINNIE0931 le 07/01/2016 18:36
Page : [1] 
Page 1 sur 1

Vous devez être connecté pour poster des messages. Cliquez ici pour vous identifier.

Vous n'avez pas de compte ? Créez-en un gratuitement !


Les bons plans du moment PC Astuces

Tous les Bons Plans
GratuitJeu PC Figment gratuit
Valable jusqu'au 02 Avril

Epic Game Store offre actuellement le jeu PC World War Z. World War Z est un jeu de tir coopératif palpitant à la troisième personne où jusqu'à 4 joueurs unissent leurs forces pour survivre à de gigantesques hordes de zombies.


> Voir l'offre
969 €Microsoft Surface Laptop 3 13,5 pouces tactile (Core i5, 8 Go, SSD 128 Go) à 969 €
Valable jusqu'au 01 Avril

Amazon fait une promotion sur le tout récent ordinateur portable Microsoft Surface Laptop 3 13 pouces tactile qui passe à 969 € livré gratuitement alors qu'on le trouve ailleurs autour de 1150 €. Cet ordinateur de très grande qualité dispose d'un écran tactile de 13 pouces 2736x1824 pixels, de 8 Go de RAM, d'un processeur Intel Core i5 3470, d'un SSD de 128 Go (qui est facilement remplaçable si besoin). Il ne pèse que 1,2 kg et offre une autonomie jusqu'à 11h30.


> Voir l'offre
279 €Casque sans fil à réduction de bruit Sony WH-1000XM3 (Hi-Res Audio, Bluetooth/NFC) à 279 €
Valable jusqu'au 07 Avril

Amazon propose actuellement le casque sans fil à réduction de bruit et Hi-Res Audio Sony WH-1000XM3 à 279 € livré gratuitement. On le trouve ailleurs à partir de 360 €. Jusqu'à 30h d'autonomie avec la fonction de réduction de bruit activée et fonction Quick Attention pour réduire instantanément le volume de votre musique et pouvoir suivre une conversation. 


> Voir l'offre

Sujets relatifs
Affichage sélectif des valeurs en abscisse, graphique Excel 2010
Excel 2010 Liste Déroulantes
Compatibilité d'office 2010 Starter (Word et Excel)
Export contact Outlook 2010 dans Excel 2010
Excel 2010 : Colorer une cellule avec des composantes RVB
Excel 2003 : formule liée entre classeurs
Excel et Office 2010
EXCEL 2010 - Format heure
Excel 2010
Excel 2010
Plus de sujets relatifs à Excel 2010 VBA synthese 2 classeurs
 > Tous les forums > Forum Bureautique