Amélioration de macro

bonjour,
merci beaucoup pour ton aide.
alors pour le 1 ça fonctionne nickel,
par contre pour le 2, cela me génère des erreurs car la suite du code ne fonctionne pas.

en fait la macro doit se stopper quand elle trouve nom de l'agence dans une colonne et passer au fichier suivant.

là elle ne prends plus en compte le stop

@cooljulyRe,

là elle ne prends plus en compte le stop
Ben oui, mais n'aillant pas le code qui suivait, c'est a vous d'adapter ou montrez la suite

@f894009ah oui pardon... j'ai pas fait attention :

Sub Synthèse()
'--- Déclaration des variables.
Dim wRec As Workbook, fRec As Worksheet, fTab As Worksheet, wImp As Workbook, fImp As Worksheet
Dim dlRec As Long, dlImp As Long, dcRec As Long, dcImp As Long, lPays As Long, lCont As Long
Dim nPoste As String, nComm As String, nRep As String, nImp As String, nPays As String, Mess As String, nCont As String
Dim tRec(), tImp()
Dim dImp As Object
Dim i As Variant, j As Variant

'--- Limitation des applications.
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'--- Détermination des variables.
Set wRec = ThisWorkbook: Set fRec = Feuil1: Set fTab = Feuil4
dlRec = fRec.Cells.Find("*", , , , xlByRows, xlPrevious).Row
dcRec = fRec.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
nRep = ThisWorkbook.Path: nImp = Dir(nRep & "\*.xls*")
tRec = fRec.Range("a6:a73")

'--- On met à zéro le fichier source.
If dcRec > 1 Then With fRec: .Range(.Cells(1, 2), .Cells(1, dcRec)).EntireColumn.Delete: dcRec = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column: End With

'--- On boucle les fichiers.
Set dImp = CreateObject("Scripting.Dictionary")
Do While nImp <> ""
If nImp <> wRec.Name Then
'- On ouvre le fichier.
Workbooks.Open Filename:=nRep & "\" & nImp
dcImp = 0
Set wImp = ActiveWorkbook: Set fImp = ActiveSheet
With fImp
'- On véfie la colonne A
tImp = .Range("a3:a70")
For i = LBound(tRec) To UBound(tRec)
If tRec(i, 1) <> tImp(i, 1) Then dImp(wImp.Name & " Ligne " & i + 2) = "": GoTo Suite
Next i
'- On enregistre le nom du poste, le commentaire, dernière ligne et dernière colonne
nComm = .Range("A71")
nPoste = .Range("A2")
dlImp = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
' dcImp = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
' dcImp = .Cells.Find("agence", , xlValues, xlPart, xlByColumns, xlPrevious).Column
dcImp = Cells.Find(What:="nom de l'agence ", After:=ActiveCell, LookIn:=xlValues _
, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column - 1
If dcImp = 0 Then ' Si on n'a pas de colonne avec "nom de l'agence"
dcImp = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
End If

'- On copie les colonnes nécessaires
.Range(Cells(1, 2), Cells(dlImp, dcImp)).Copy fRec.Cells(4, dcRec + 1)
End With

'- On note le nom du poste
With fRec
.Range(.Cells(3, dcRec + 1), .Cells(3, dcRec + dcImp - 1)).Value = nPoste
.Range(.Cells(73, dcRec + 1), .Cells(73, dcRec + dcImp - 1)).Value = nComm
'- On ajoute la recherche
On Error Resume Next
lPays = WorksheetFunction.Match(nPoste, fTab.Range("a:a"), 0)
nPays = fTab.Cells(lPays, 2).Value
.Range(.Cells(2, dcRec + 1), .Cells(2, dcRec + dcImp - 1)).Value = nPays
lCont = WorksheetFunction.Match(nPays, fTab.Range("b:b"), 0)
nCont = fTab.Cells(lCont, 3).Value
.Range(.Cells(1, dcRec + 1), .Cells(1, dcRec + dcImp - 1)).Value = nCont
End With
Suite:
'- On ferme le classeur
wImp.Close False
End If
'--- On cherche le fichier suivant
nImp = Dir
'--- On recalcule la dernière colonne
dcRec = fRec.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
'--- On continue la boucle
Loop

'--- Limitation des applications.
Application.ScreenUpdating = True
Application.DisplayAlerts = True

'--- On affiche la liste des fichiers non importés dans la feuille "Compte-rendu"
Sheets("Compte-rendu").Select
Range("A1").Select
ActiveCell.Value = "Messages"

For Each j In dImp.Keys
' Mess = Mess & j & Chr(13)
ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
ActiveCell.Value = j

Next j
' MsgBox Mess
' ActiveCell.FormulaR1C1 = "CR"
End Sub

@cooljulyRe,

A priori ca doit marcher !!

Sub Synthèse()
'--- Déclaration des variables.
Dim wRec As Workbook, fRec As Worksheet, fTab As Worksheet, wImp As Workbook, fImp As Worksheet
Dim dlRec As Long, dlImp As Long, dcRec As Long, dcImp As Long, lPays As Long, lCont As Long
Dim nPoste As String, nComm As String, nRep As String, nImp As String, nPays As String, Mess As String, nCont As String
Dim tRec(), tImp()
Dim dImp As Object
Dim i As Variant, j As Variant

Dim dcIm As Object
Dim dcImp As Long


'--- Limitation des applications.
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'--- Détermination des variables.
Set wRec = ThisWorkbook: Set fRec = Feuil1: Set fTab = Feuil4
dlRec = fRec.Cells.Find("*", , , , xlByRows, xlPrevious).Row
dcRec = fRec.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
nRep = ThisWorkbook.Path: nImp = Dir(nRep & "\*.xls*")
tRec = fRec.Range("a6:a73")

'--- On met à zéro le fichier source.
If dcRec > 1 Then With fRec: .Range(.Cells(1, 2), .Cells(1, dcRec)).EntireColumn.Delete: dcRec = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column: End With

'--- On boucle les fichiers.
Set dImp = CreateObject("Scripting.Dictionary")
Do While nImp <> ""
    If nImp <> wRec.Name Then
        '- On ouvre le fichier.
        Workbooks.Open Filename:=nRep & "\" & nImp
        dcImp = 0
        Set wImp = ActiveWorkbook: Set fImp = ActiveSheet
        With fImp
            '- On véfie la colonne A
            tImp = .Range("a3:a70")
            For i = LBound(tRec) To UBound(tRec)
                If tRec(i, 1) <> tImp(i, 1) Then dImp(wImp.Name & " Ligne " & i + 2) = "": GoTo Suite
            Next i
            '- On enregistre le nom du poste, le commentaire, dernière ligne et dernière colonne
            nComm = .Range("A71")
            nPoste = .Range("A2")
            dlImp = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
            '---------------------------------------------------
            'dcImp = Cells.Find(What:="nom de l'agence ", After:=ActiveCell, LookIn:=xlValues _
                            , LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
                            MatchCase:=False, SearchFormat:=False).Column - 1
            Set dcIm = .Range("2:2").Find("nom de l'agence", LookAt:=xlWhole)
            If dcIm Is Nothing Then
                dcImp = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            Else
                dcImp = dcIm.Column - 1     'pourquoi -1 ?????
            End If
            '---------------------------------------------------
            '- On copie les colonnes nécessaires
            .Range(Cells(1, 2), Cells(dlImp, dcImp)).Copy fRec.Cells(4, dcRec + 1)
        End With

        '- On note le nom du poste
        With fRec
            .Range(.Cells(3, dcRec + 1), .Cells(3, dcRec + dcImp - 1)).Value = nPoste
            .Range(.Cells(73, dcRec + 1), .Cells(73, dcRec + dcImp - 1)).Value = nComm
            '- On ajoute la recherche
            On Error Resume Next
            lPays = WorksheetFunction.Match(nPoste, fTab.Range("a:a"), 0)
            nPays = fTab.Cells(lPays, 2).Value
            .Range(.Cells(2, dcRec + 1), .Cells(2, dcRec + dcImp - 1)).Value = nPays
            lCont = WorksheetFunction.Match(nPays, fTab.Range("b:b"), 0)
            nCont = fTab.Cells(lCont, 3).Value
            .Range(.Cells(1, dcRec + 1), .Cells(1, dcRec + dcImp - 1)).Value = nCont
        End With
Suite:
        '- On ferme le classeur
        wImp.Close False
    End If
    '--- On cherche le fichier suivant
    nImp = Dir
    '--- On recalcule la dernière colonne
    dcRec = fRec.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    '--- On continue la boucle
Loop

'--- Limitation des applications.
Application.ScreenUpdating = True
Application.DisplayAlerts = True

'--- On affiche la liste des fichiers non importés dans la feuille "Compte-rendu"
Sheets("Compte-rendu").Select
Range("A1").Select
ActiveCell.Value = "Messages"

For Each j In dImp.Keys
' Mess = Mess & j & Chr(13)
ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
ActiveCell.Value = j

Next j
' MsgBox Mess
' ActiveCell.FormulaR1C1 = "CR"
End Sub

oui c'est parfait.
merci.

j'avais en fait un soucis d'espace après agence.

très bonne soirée