MACRO recherche automatique

roidurif · 7 Novembre 2008

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

Guest · 7 Novembre 2008

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+

Gael · 7 Novembre 2008

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

Gael · 7 Novembre 2008

Re : MACRO recherche automatique

Re,

Hasco, j'ai testé ta macro et la mise à jour ne se fait pas sur tous les contrats et le format date disparaît, as-tu les mêmes problèmes ?

@+

Gael

Guest · 7 Novembre 2008

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+

roidurif · 7 Novembre 2008

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

Guest · 7 Novembre 2008

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

roidurif · 9 Novembre 2008

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

Gael · 9 Novembre 2008

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

roidurif · 9 Novembre 2008

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

Gael · 10 Novembre 2008

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

roidurif · 10 Novembre 2008

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

Gael · 10 Novembre 2008

Re : MACRO recherche automatique

Re,

Mets plutôt:

Code:

Dim WbDest as variant

c'est le test si <> False qui pose problème.

@+

Gael

roidurif · 10 Novembre 2008

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

Guest · 10 Novembre 2008

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+

MACRO recherche automatique

roidurif

XLDnaute Occasionnel

Pièces jointes

Guest

Guest

Gael

XLDnaute Barbatruc

Pièces jointes

Gael

XLDnaute Barbatruc

Guest

Guest

roidurif

XLDnaute Occasionnel

Guest

Guest

roidurif

XLDnaute Occasionnel

Gael

XLDnaute Barbatruc

roidurif

XLDnaute Occasionnel

Gael

XLDnaute Barbatruc

roidurif

XLDnaute Occasionnel

Pièces jointes

Gael

XLDnaute Barbatruc

roidurif

XLDnaute Occasionnel

Guest

Guest

Discussions similaires

MACRO recherche automatique

XLDnaute Occasionnel

Pièces jointes

Guest

Guest

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Guest

Guest

XLDnaute Occasionnel

Guest

Guest

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Occasionnel

Guest

Guest

Discussions similaires

Privacy & Transparency

Privacy & Transparency