Bonjour,

J'ai un fichier avec une macro qui permettait de faire plusieurs choses (fusion de plusieurs fichiers, remplacement des caractères spéciaux par des caractères sans accent..) qui fonctionne très bien sous excel 2010 mais qui ne passe plus dans excel 2013.
Je ne suis pas développeur et manque de budget pour faire appel à un free lance pour quelque chose qui n'est peut-être pas compliqué.
Est-ce que l'un(e) d'entre vous pourrait me dire s'il faut faire réécrire le script de A à Z ou s'il peut être réparé facilement et rapidement svp ?

Je colle la fonction ci-dessous, merci par avance à celles et ceux qui pourront m'aider,

Alex

_________________________________________________________________________________________________________________
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
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
Sub Bouton1_Clic()
    Dim strCheminCourant As String
    Dim xlApp As New Excel.Application
    Dim xlSheet As Worksheet
    Dim i As Integer
    Dim ctlBouton As Shape
 
    Const cstAmericas = "americas"
    Const cstAspac = "aspac"
    Const cstEmoa = "emoa"
 
    On Error GoTo err_fctButon
 
    strCheminCourant = ThisWorkbook.Path & "\"
 
    Call fctCopieDonnees(cstAmericas, strCheminCourant)
    Call fctCopieDonnees(cstAspac, strCheminCourant)
    Call fctCopieDonnees(cstEmoa, strCheminCourant)
 
    ' création d'un classeur dans lequel je copie mes feuilles actuelles
    ' pour obtenir un classeur sans macro
    Set xlBook = Workbooks.Add
    For i = 1 To ThisWorkbook.Sheets.Count
        ThisWorkbook.Sheets(i).Copy after:=xlBook.Sheets(xlBook.Sheets.Count)
    Next i
 
    ' je supprime les feuilles creees par defaut
    Application.DisplayAlerts = False
    For Each xlSheet In xlBook.Worksheets
        If xlSheet.Name <> cstAmericas And xlSheet.Name <> cstAspac And xlSheet.Name <> cstEmoa Then
            xlSheet.Delete
        End If
    Next
    Application.DisplayAlerts = True
 
    ' je supprime le bouton de lancement
    Sheets(cstAmericas).Select
    For Each ctlBouton In ActiveSheet.Shapes
        ctlBouton.Delete
    Next
 
'    ' masquage des colonnes
'    Columns("L:L").Select
'    Selection.EntireColumn.Hidden = True
'    Columns("M:M").Select
'    Selection.EntireColumn.Hidden = True
 
    ' sauvegarde du fichier sans macro
    xlBook.SaveAs (strCheminCourant & "Consolidation BOD 2010")
 
    Call MsgBox("Génération terminée.", vbInformation)
 
    ' je ferme le classeur source sans sauvegarde
    ThisWorkbook.Close savechanges:=False
 
Exit Sub
 
err_fctButon:
    If Err.Number = 1004 Then
        ThisWorkbook.Close savechanges:=False
    Else
        MsgBox Err.Description
    End If
End Sub
 
Private Function fctCopieDonnees(strRegion As String, strCheminCourant As String)
Dim xlApp As New Excel.Application
Dim xlBookSource As Workbook
Dim xlSheetSource As Excel.Worksheet
Dim tabFichiers() As String
Dim strFichier As String
Dim intNbLignes As Integer
Dim intLignePourColler As Integer
Dim i As Integer
Dim intNbFichiers As Integer
 
On Error GoTo err_fctCopieDonnees
    intNbLignes = 0
    ReDim tabFichiers(1)
    i = 0
    intLignePourColler = 2
 
    ' test si le sous-dossier
    If fctVerifDossier(strCheminCourant & strRegion) Then
        ' parcourir le dossier et retrouver la liste des fichiers que je stocke dans un tableau
        strFichier = Dir(strCheminCourant & strRegion & "\*.xls", 16)
        Do
            If strFichier = "" Then
                Exit Do
            Else
                tabFichiers(i) = strFichier
                i = i + 1
                ReDim Preserve tabFichiers(i)
            End If
            strFichier = Dir
        Loop
 
        intNbFichiers = i
 
        ' pour chacun des fichiers
        For i = 0 To intNbFichiers - 1
            Set xlBookSource = xlApp.Workbooks.Open(strCheminCourant & strRegion & "\" & tabFichiers(i))
            For Each xlSheetSource In xlBookSource.Sheets
                ' copie des donnees de chaque feuille
                xlSheetSource.Activate
                xlSheetSource.Range("A2").Select
                intNbLignes = xlSheetSource.Range("A65536").End(xlUp).Row
                xlSheetSource.Range("A2:M" & intNbLignes).Select
                xlApp.Selection.Copy
 
                ' je colle les donnees
                ActiveWorkbook.Sheets(strRegion).Select
                ActiveWorkbook.Sheets(strRegion).Range("A" & intLignePourColler).Select
                ActiveWorkbook.Sheets(strRegion).Paste
                intLignePourColler = intLignePourColler + intNbLignes - 1
            Next xlSheetSource
 
            ' comme la fermeture sans vider presse papier pose pb lorsque celui-ci contient bcp de donnees
            ' je copie seulement une petite zone pour ecraser le PP courant puis ferme le classeur
            Range("A1").Select
            Selection.Copy
            xlBookSource.Close
        Next i
    End If
 
    ' masquage des colonnes
    Columns("L:L").Select
    Selection.EntireColumn.Hidden = True
    Columns("M:M").Select
    Selection.EntireColumn.Hidden = True
 
    ActiveWorkbook.Sheets(strRegion).Range("A1").Select
 
Exit Function
 
err_fctCopieDonnees:
    xlApp.Quit
    Set xlApp = Nothing
 
End Function
 
Private Function fctVerifDossier(strDossier As String) As Boolean
 
    If Dir(strDossier, vbDirectory) <> "" Then
        fctVerifDossier = True
    Else
        fctVerifDossier = False
    End If
 
End Function
_________________________________________________________________________________________________