Bonjour,

Le titre parle de lui même. En gras ce que je n'arrive pas à exprimer. En commentaire ce qui est à mon avis inutile.
Avec le code ci-dessous l'erreur est: Erreur d'exécution '1004' Erreur définie par l'application ou par l'objet. Je pense que le x et le y doivent être présenté à la fonction mais je ne sais pas comment.

Voici la procédure:
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

Application.DisplayAlerts = False
 
Const FileSource As String = "Sport"
 
Dim WkbSrce As Workbook
Dim FoldersSource As Variant
Dim SubFolder As String
Dim i As Integer
Dim x As Integer
Dim y As Integer
 
x = Target.Row
y = Target.Column 
SubFolder = ThisWorkbook.ActiveSheet.Name

'Windows("Ce fichier").Activate
'Sheets("SubFolder").Select
Cells(x, y).Select
Selection.Copy

If SubFolder Like "STR####" Then
    FoldersSource = Array("C:\Users\105063782\Desktop\Réseau test\TDSK\TV\", "C:\Users\105063782\Desktop\Réseau test\TDSA\TV\")
ElseIf SubFolder Like "SCR####" Then
    FoldersSource = Array("C:\Users\105063782\Desktop\Réseau test\TDSK\CC\", "C:\Users\105063782\Desktop\Réseau test\TDSA\CC\")
Else
Application.DisplayAlerts = True
    Exit Sub
End If
 
For i = 0 To UBound(FoldersSource)
    If Exporter(FoldersSource(i), SubFolder, FileSource & ".xlsx") Then
        Exit For
    End If
Next i
 
Application.DisplayAlerts = True

End Sub
Voici la fonction appelée par la procédure:
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Private Function Exporter(ByVal Dossier As String, ByVal SousDossier As String, ByVal Fichier As String) As Boolean

Dim FichTrouve As String, SubFolder As String
Dim WkbSrce As Workbook
Dim x As Integer
Dim y As Integer

Application.ScreenUpdating = False

SubFolder = FindSubFolder(Dossier, SousDossier)

If SubFolder <> "" Then
    FichTrouve = Dir(SubFolder & "\" & Fichier)
 
    If FichTrouve <> "" Then
        Exporter = True
        Do While FichTrouve <> ""
            Set WkbSrce = Application.Workbooks.Open(SubFolder & "\" & Fichier)

            'Windows(Fichier).Activate
            'ThisWorkbook.Worksheets(1).Select
            Cells(x, y).Select
            ActiveCell.Paste
            
            Application.ScreenUpdating = True
 
            WkbSrce.Save
            WkbSrce.Close False
            Set WkbSrce = Nothing
            FichTrouve = Dir()
            
        Loop
    End If
End If

End Function
Si vous avez des suggestions... Merci.

Thomas