Bonjour et joyeux noël à tous,
BonjourChTi160 et merci pour la persévérance dans ton aide
Après les modification que tu m'as demandé d'effectuer et que j'espère avoir fait au mieux, il m'envoie le message suivant :
Erreur d'exeécution 52
Sur la ligne suivante de la macro "ouvrir fichiers" :
Fichier = Dir(Chemin & "Combis *.xls*")
Ci-Dessous et en rouge, ce que j'ai copié et mofidié dans un module de base :
Option Explicit
Option Base 1
Public Tab_Recup As Variant
Public Tab_Recap() As Variant
Public Tab_Ws() As Variant
Public i As Long
Public DerLgn As Integer
Public Lgn As Integer
Public L As Integer
Public C As Byte
Public col As Byte
Public DerCol As Byte
Public Ws_Source As Worksheet
Public Ws_Cible As Worksheet
Public Ws As Worksheet
Public Ws_Base As Worksheet
Public WkB_Source As Workbook
Public Str_Sht As String
Public Str_Text As String
Sub Ouvrirfichiers()
Dim Fichier As String, Chemin As String, Wb As Workbook
Application.ScreenUpdating = False
Chemin = ThisWorkbook.Path & "C:\Users\Thierry\Desktop\Courses Galop 2018\" 'adapter chemin
Fichier = Dir(Chemin & "Combis *.xls*")
Do While Fichier <> ""
Set WkB_Source = Workbooks.Open(Chemin & Fichier)
'suite de la procedure
'**********************************
CopieDonnéesBaseDansFeuilles WkB_Source 'appel de tes macros
CompterEcarts
Effacer
RécupérerEcartsMax
'**********************************
Application.DisplayAlerts = False
Application.DisplayAlerts = True
Set WkB_Source = Nothing
Fichier = Dir
Loop
Application.ScreenUpdating = True
End Sub
'*******************
Sub CopieDonnéesBaseDansFeuilles(ByVal WkB_Source As Workbook)
Application.ScreenUpdating = False
Dim ShtName As String
Dim ShtCompare As String
Dim Idx As Long
'On Error Resume Next
With WkB_Source 'avec le Classeur
Set Ws_Base = .Worksheets("Base")
With Ws_Base
DerLgn = .Cells(.Rows.Count, 1).End(xlUp).Row
If DerLgn = 1 Then GoTo suite
With .Range(.Cells(1, 1), .Cells(DerLgn, 9))
.Sort key1:=.Cells(1, 1), order1:=xlAscending, key2:=.Cells(1, 2), Order2:=xlAscending, Header:=xlNo
Tab_Recup = .Value
End With
End With
For L = 1 To UBound(Tab_Recup, 1)
ShtName = Tab_Recup(L, 1)
Idx = Mid(ShtName, 2)
For Each Ws In .Worksheets
ShtCompare = Ws.Name
If InStr(2, ShtCompare, Idx) <> 0 Then
With .Worksheets(ShtCompare)
DerLgn = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
For C = 1 To UBound(Tab_Recup, 2)
.Cells(DerLgn, C) = Tab_Recup(L, C)
Next C
.Cells.EntireColumn.AutoFit
End With
End If
Next Ws
Next L
suite:
.Close True
End With
Erase Tab_Recup
Set Ws = Nothing
Application.ScreenUpdating = True
End Sub
Sub CompterEcarts()
Dim Ws As Worksheet, ec%, i%
Application.ScreenUpdating = False
For Each Ws In Worksheets
With Ws.Columns("I")
If .Cells(1, 1) <> "" Then i = 1 Else i = 2
Do While .Cells(i, 1) <> ""
If .Cells(i, 1) = "*" Then
ec = ec + 1
ElseIf .Cells(i, 1) = 0 Then
.Cells(i, 2) = ec: ec = 0
End If
i = i + 1
Loop
If ec > 0 Then .Cells(i - 1, 3) = ec: ec = 0
End With
Next Ws
End Sub
Sub Effacer()
Dim Ws As Worksheet
For Each Ws In Worksheets
Ws.Columns("J:K").ClearContents
Next Ws
End Sub
Option Explicit
Dim f As Worksheet, col&
Sub RécupérerEcartsMax()
Application.ScreenUpdating = False
Cells.ClearContents
For Each f In Worksheets
If f.Name <> ActiveSheet.Name Then
f.Range("J1:J" & f.Range("J" & Rows.Count).End(xlUp).Row).Copy
col = Cells(1, Columns.Count).End(xlToLeft).Column + 1
Cells(1, col).Value = f.Name
Cells(2, col).PasteSpecial xlPasteAll
Range(Cells(2, col), Cells(Cells(Rows.Count, col).End(xlUp).Row, col)).Select
Range(Cells(2, col), Cells(Cells(Rows.Count, col).End(xlUp).Row, col)).Sort _
key1:=Cells(2, col), order1:=xlDescending, Header:=xlNo
End If
Next f
Range("A1").Select
End Sub
