MACRO recherche automatique

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
R

roidurif

XLDnaute Occasionnel
Bonjour

Je souhaite créer une MACRO dans le fichier "Base_contrat", en cliquant sur un bouton par exemple :

- Demande à ouvrir un 2eme fichier exemple: "fichier à reseigner",
- Une fois le "fichier à renseigner" est ouvert ,
- recherche automatiquement dans la colonne A du 'fichier à renseigner ' , les anciens contrats puis les remplaces par le nouveau du fichier 'Base_contrat'
- renseigne automatiquement dans la colonne C du 'fichier à renseigner ' , la date de fin du nouveau contrat du fichier 'Base_contrat'

Merci de votre aide SVP

Ci joint les fichier .xls
 

Pièces jointes

Trier par date Trier par votes
Re : MACRO recherche automatique

Bonjour roidurif,

Voici une macro qui le fait sur l'exemple que tu nous à fournit.
Au passage, tu aurais pu faire en sorte qu'il y ait des numéros de contrats identiques à remplacer dans le fichier à renseigner.

Code: 
Sub MiseAJourContrats()
    Dim WbDest As Workbook
    Dim shDest As Worksheet
    Dim PlageSource As Range, PlageDest As Range, cSource As Range, cDest As Range
 
    With Sheets("Table")
        Set PlageSource = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    End With
    'Si le classeur n'est pas là sortir
    If Dir(ThisWorkbook.Path & "\Fichier à renseigner.xls") = "" Then Exit Sub
    'Ouverture du classeur
    Set WbDest = Workbooks.Open(ThisWorkbook.Path & "\Fichier à renseigner.xls")
    'La feuille à renseigner
    On Error Resume Next
    Set shDest = WbDest.Sheets("A renseigner")
    On Error GoTo 0
    'Si elle n'existe pas sortir
    If shDest Is Nothing Then Exit Sub
    'Déterminer la plage des numéro de contrat
    With shDest
        Set PlageDest = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    End With
    For Each cSource In PlageSource.Cells
        Set cDest = PlageDest.Find(what:=cSource, LookIn:=xlValues, lookat:=xlWhole)
        If Not cDest Is Nothing Then
            With cDest
                .Value = cSource.Offset(, 1)          'Nouveau Numéro de contrat
                .Offset(, 2) = cSource.Offset(, 2)    'Date Fin
            End With
        End If
    Next cSource
End Sub

A+
 
Vote positif 0 Vote négatif
Re : MACRO recherche automatique

Bonjour Roidurif, bonjour Hasco,

Ci-joint un autre exemple, moins complet et sécurisé que celui de mon ami Hasco, mais puisque j'ai travaillé, je le joins quand même.

A mettre dans le même répertoire que "Fichier à renseigner.xls"

@+

Gael
 

Pièces jointes

Vote positif 0 Vote négatif
Re : MACRO recherche automatique

Gaël🙂

Pour la date tu as raison, voici la boucle modifiée pour mettre le format.

Code: 
    For Each cSource In PlageSource.Cells
        Set cDest = PlageDest.Find(what:=cSource, LookIn:=xlValues, lookat:=xlWhole)
        If Not cDest Is Nothing Then
            With cDest
                .Value = cSource.Offset(, 1)          'Nouveau Numéro de contrat
                With .Offset(, 2)
                    .Value = cSource.Offset(, 2) 'Date Fin
                    .NumberFormat = "dd/mm/yyyy"
                End With
            End With
        End If
    Next cSource

Quant aux numéros de contrats, c'est normal étant donné que notre ami nous a fourni, des données, construites à la va vite, je pense. Sans nous dire non plus que faire des doublons. Alors attendons de voir. J'ai testé avec des numéros uniques recopiés du classeur origine, cela fonctionne parfaitement.

[Edition] ci-joint les fichiers sur lesquels j'ai travaillé.
A+
 
Dernière modification par un modérateur:
Vote positif 0 Vote négatif
Re : MACRO recherche automatique

Merci les amis,

Je viens d'essayer votre dernier fichier envoyer par HASCO ke je remercie,

Par contre, ça le fait pas quand il y a des doublons.

Pour repondre à la question des doublons, il est normal qu il yai des doublons, il faudra faire une RECHERCHE et REMPLACE des anciens contrats par des Nouveaux contrats.

Je vous remercie les amis pour votre aide
 
Dernière édition:
Vote positif 0 Vote négatif
Re : MACRO recherche automatique

Re bonjour,

re voici la macro modifiée pour tenir compte des doublons du classeur 'Fichier à renseigner':

Code: 
ub MiseAJourContrats()
    Dim WbDest As Workbook
    Dim shDest As Worksheet
    Dim PlageSource As Range, PlageDest As Range, cSource As Range, cDest As Range
    Dim Adr1 As String
    With Sheets("Table")
        Set PlageSource = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    End With
    'Si le classeur n'est pas là sortir
    If Dir(ThisWorkbook.Path & "\Fichier à renseigner.xls") = "" Then Exit Sub
    'Ouverture du classeur
    Set WbDest = Workbooks.Open(ThisWorkbook.Path & "\Fichier à renseigner.xls")
    'La feuille à renseigner
    On Error Resume Next
    Set shDest = WbDest.Sheets("A renseigner")
    On Error GoTo 0
    'Si elle n'existe pas sortir
    If shDest Is Nothing Then Exit Sub
    'Déterminer la plage des numéro de contrat
    With shDest
        Set PlageDest = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    End With
    For Each cSource In PlageSource.Cells
        With PlageDest
            Set cDest = .Find(what:=cSource, LookIn:=xlValues, lookat:=xlWhole)
            If Not cDest Is Nothing Then
                Adr1 = cDest.Address
                Do
                    With cDest
                        .Value = cSource.Offset(, 1)  'Nouveau Numéro de contrat
                        With .Offset(, 2)
                            .Value = cSource.Offset(, 2)    'Date Fin
                            .NumberFormat = "dd/mm/yyyy"
                        End With
                    End With
                    Set cDest = .FindNext(cSource)
                    If cDest Is Nothing Then Exit Do
                Loop While cDest.Address <> Adr1
            End If
        End With
    Next cSource
End Sub

A bientôt
 
Vote positif 0 Vote négatif
Re : MACRO recherche automatique

merci HASCO,

est'il possible, dans une cette macro, d'ouvrir un fichier excel sans en connaitre le nom. L'ideal serait qu'une fenetre s'ouvre et que l'utilisateur aille indiquer le fichier à ouvrir "fichier à renseigner" , comme quand on clique sur "ouvrir" dans excel.

Merci pour les infos
 
Vote positif 0 Vote négatif
Re : MACRO recherche automatique

Bonsoir Roidurif, salut Hasco,

essaye en remplacant dans la procédure de Hasco:

Code: 
'Si le classeur n'est pas là sortir
    If Dir(ThisWorkbook.Path & "\Fichier à renseigner.xls") = "" Then Exit Sub
    'Ouverture du classeur
    Set WbDest = Workbooks.Open(ThisWorkbook.Path & "\Fichier à renseigner.xls")

par les instructions suivantes:

Code: 
WbDest = Application.GetOpenFilename(filefilter:="Classeur Microsoft Excel (*.xls),*.xls", Title:="Choisir le fichier souhaité")
If WbDest <> False Then
Workbooks.Open Filename:=WbDest
Else
Exit Sub
End if

Pour que ça marche, il faut changer la définition de Wbdest par:

Code: 
Dim WbDest As String

Tu peux modifier le titre "Choisir le fichier souhaité" par ce que tu veux, c'est simplement le titre de la fenêtre.

@+

Gael

PS: la fenêtre va s'ouvrir sur le répertoire par défaut défini dans Excel (outils - options) je ne sais pas comment ouvrir automatiquement sur le chemin en cours "Thisworkbook.path". Hasco, si tu as une idée?

Gael
 
Dernière édition:
Vote positif 0 Vote négatif
Re : MACRO recherche automatique

je n'arrive pas, j ai fait ce que vous m avez demander

Sub MiseAJourContrats()
Dim WbDest As Workbook
Dim shDest As Worksheet
Dim PlageSource As Range, PlageDest As Range, cSource As Range, cDest As Range
Dim Adr1 As String
With Sheets("Table")
Set PlageSource = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
WbDest = Application.GetOpenFilename(filefilter:="Classeur Microsoft Excel (*.xls),*.xls", Title:="Choisir le fichier souhaité")
If WbDest <> False Then
Workbooks.Open Filename:=WbDest
Else
Exit Sub
End If
'La feuille à renseigner
On Error Resume Next
Set shDest = WbDest.Sheets("A renseigner")
On Error GoTo 0
'Si elle n'existe pas sortir
If shDest Is Nothing Then Exit Sub
'Déterminer la plage des numéro de contrat
With shDest
Set PlageDest = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
For Each cSource In PlageSource.Cells
With PlageDest
Set cDest = .Find(what:=cSource, LookIn:=xlValues, lookat:=xlWhole)
If Not cDest Is Nothing Then
Adr1 = cDest.Address
Do
With cDest
.Value = cSource.Offset(, 1) 'Nouveau Numéro de contrat
With .Offset(, 2)
.Value = cSource.Offset(, 2) 'Date Fin
.NumberFormat = "dd/mm/yyyy"
End With
End With
Set cDest = .FindNext(cSource)
If cDest Is Nothing Then Exit Do
Loop While cDest.Address <> Adr1
End If
End With
Next cSource
End Sub
 
Vote positif 0 Vote négatif
Re : MACRO recherche automatique

Bonjour Roidurif, bonjour à tous,

Tu as oublié de mettre Dim Wbdest as string au lieu de Workbook. Cela génère une erreur 91.

Par ailleurs, j'ai trouvé la syntaxe pour que la fenêtre s'ouvre sur le répertoire en cours:

Code: 
Wbdest = Application.GetOpenFilename(filefilter:="Classeur Microsoft Excel (*.xls)," & ThisWorkbook.Path & "\" & "*.xls", Title:="Choisir le fichier souhaité")

@+

Gael
 
Vote positif 0 Vote négatif
Re : MACRO recherche automatique

merci gael pour ton aide

cette fois ci la fonction ouvrir le fichier fonctionne, mais une fois le fichier selectionné j'ai une erreure code 13.

Je joins mon fichier, la macro est dans le fichier 'Base contrat' et le fichier à selectionner est ' fichier à renseigner'

merci de votre aide cordialement
 

Pièces jointes

Vote positif 0 Vote négatif
Re : MACRO recherche automatique

Merci gael pour ton aide,

Cette fois ci, en faisant ce que tu ma dit, la macro recherche et remplace ne fait rien.

je te remerci de ton aide

Sub MiseAJourContrats()
Dim WbDest As Variant
Dim shDest As Worksheet
Dim PlageSource As Range, PlageDest As Range, cSource As Range, cDest As Range
Dim Adr1 As String
With Sheets("Table")
Set PlageSource = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
WbDest = Application.GetOpenFilename(filefilter:="Classeur Microsoft Excel (*.xls)," & ThisWorkbook.Path & "\" & "*.xls", Title:="Choisir le fichier souhaité")
If WbDest <> False Then
Workbooks.Open Filename:=WbDest
Else
Exit Sub
End If
'La feuille à renseigner
On Error Resume Next
Set shDest = WbDest.Sheets("A renseigner")
On Error GoTo 0
'Si elle n'existe pas sortir
If shDest Is Nothing Then Exit Sub
'Déterminer la plage des numéro de contrat
With shDest
Set PlageDest = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
For Each cSource In PlageSource.Cells
With PlageDest
Set cDest = .Find(what:=cSource, LookIn:=xlValues, lookat:=xlWhole)
If Not cDest Is Nothing Then
Adr1 = cDest.Address
Do
With cDest
.Value = cSource.Offset(, 1) 'Nouveau Numéro de contrat
With .Offset(, 2)
.Value = cSource.Offset(, 2) 'Date Fin
.NumberFormat = "dd/mm/yyyy"
End With
End With
Set cDest = .FindNext(cSource)
If cDest Is Nothing Then Exit Do
Loop While cDest.Address <> Adr1
End If
End With
Next cSource
End Sub
 
Vote positif 0 Vote négatif
Re : MACRO recherche automatique

Bonjour roidurif, Gaël,

Code: 
Sub MiseAJourContrats()
[SIZE=3][COLOR=red]Dim NomFichier as Variant[/COLOR][/SIZE]
Dim WbDest As WorkBook
Dim shDest As Worksheet
Dim PlageSource As Range, PlageDest As Range, cSource As Range, cDest As Range
Dim Adr1 As String
With Sheets("Table")
Set PlageSource = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
[SIZE=3][COLOR=red]NomFichier[/COLOR][/SIZE] = Application.GetOpenFilename(filefilter:="Classeur Microsoft Excel (*.xls)," & ThisWorkbook.Path & "\" & "*.xls", Title:="Choisir le fichier souhaité")
If [SIZE=3][COLOR=red]NomFichier[/COLOR][/SIZE] <> False Then
     'Reférencer le classeur 
     [COLOR=blue]Set WDest = Workbooks.Open( Filename:=[COLOR=darkorange]NomFichier[/COLOR])[/COLOR]
Else
Exit Sub
End If
 
'Suite du code

Avec ceci cela devrait fonctionner.

A+
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

R
  • Question Question
XL 2019 Besoin d'aide pour remplissage automatique
Réponses
12
Affichages
280
rmjunivers
R
W
  • Question Question
Microsoft 365 Macro pour un bilan fonctionnement coloré
Réponses
3
Affichages
134
sylvanu
sylvanu
Y
  • Résolu(e)
XL 2016 Calculs automatique XO pour des valeurs dans un tableau
Réponses
3
Affichages
148
dysorthographie
dysorthographie
D
  • Résolu(e)
XL 2016 Alimenter une combobox sur une feuille de calcul
Réponses
11
Affichages
398
dgil37
D
D
  • Question Question
XL 2021 Création automatique de lien hypertexte
Réponses
4
Affichages
213
Dimitry
D
E
  • Question Question
XL 2021 Calculer le nombre de contrat représentant 90% du CA
Réponses
4
Affichages
246
chris
chris
C
  • Résolu(e)
XL 2016 humains VS chatGPT
Réponses
9
Affichages
907
AtTheOne
AtTheOne
D
  • Question Question
Microsoft 365 TCD et sélection automatique suivant les filtres
Réponses
2
Affichages
219
Daniel200666
D
M
  • Question Question
XL 2021 Macro
Réponses
6
Affichages
321
AtTheOne
AtTheOne
S
  • Résolu(e)
XL 2021 enregistrer xltm en xlsm avec chemin automatiquement
2
Réponses
27
Affichages
606
TooFatBoy
TooFatBoy
N
  • Question Question
Autres comment effectuer une recherche ordre
2
Réponses
27
Affichages
791
n_turf
N
P
  • Question Question
XL 2021 Macro de découpage suivant une clé
Réponses
14
Affichages
527
job75
job75
Agecanonix35400
  • Question Question
XL 2016 * RESOLU *Automatisation jours de récup
Réponses
2
Affichages
216
Agecanonix35400
Agecanonix35400
L
  • Résolu(e)
XL 2021 Macro - Liste déroulante
Réponses
4
Affichages
180
Piment
P
K
  • Résolu(e)
XL 2010 Roulement automatique
Réponses
9
Affichages
360
komarlehomard
K
O
  • Question Question
XL 2013 Planification automatique des rdv d'intervention en fonction des dates disponibles
Réponses
3
Affichages
463
cathodique
cathodique
pompaero
  • Question Question
Microsoft 365 impliquer plusieurs recherche avec index equiv
2 3
Réponses
30
Affichages
2 K
TooFatBoy
TooFatBoy
D
  • Question Question
Microsoft 365 calcul d'une moyenne automatique par trimestre, semestre et annuelle
Réponses
0
Affichages
174
Daniel200666
D
scoobytor
  • Résolu(e)
XL 2021 Code vba pour filtres automatiques sans le nom de l'onglet
Réponses
4
Affichages
205
sylvanu
sylvanu
F
  • Question Question
XL 2016 recherche données et collage
Réponses
4
Affichages
233
finarobert
F
Retour