Afin de ne pas me mélanger dans un seul post je mets ici une copie de ma procédure de traitement de mon fichier source.
J'ai placé ton code vers le bas
Private Sub TRAITEMENT_FICHIER_SOURCE_Click()
Dim MonFichier As String, i As Integer
Dim xlApp As Object
Dim MonWk As Object
Dim MaFeuil As Object
Dim plage(50) As String, nbf As Integer
'supprime les enregistrements déjà présents de la table SCORPENE>>>>>>>>>>>>>>>>>>>>>>>>>>>
CodeDb.Execute 'delete * from SCORPENE'
MonFichier = OuvrirUnFichier(hWndAccessApp, 'Ouvrir', 1, 'Microsoft Excel', 'xls', CurrentProject.Path) 'ouvre le fichier
If MonFichier = '' Then Exit Sub
'sortie si pas de sélection de fichier
'création de l'objet Excel>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Set MonExcel = CreateObject('excel.application')
MonExcel.Visible = False
'force à invisible
'ouvre le fichier>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Set MonWk = MonExcel.Workbooks.Open(MonFichier)
nbf = MonWk.Sheets.Count
'sauve le nombre de feuilles présentes
For i = 1 To Worksheets.Count
Worksheets(i).Activate
' suppression des filtres>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Selection.AutoFilter
' libération des volets>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ActiveWindow.FreezePanes = False
' suppression des 3 premières lignes>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Rows('1:3').Select
Selection.Delete Shift:=xlUp
' insertion 3 colonnes en A B et C pour y placer les données>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Columns('A:A').Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Next
' Insertion colonne repere nature sur l'onglet tuyau>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Sheets('Tuyau').Select
Columns('E:E').Select
Selection.Insert Shift:=xlToRight
Range('E1').Select
ActiveCell.FormulaR1C1 = 'Repere Nature'
With ActiveCell.Characters(Start:=1, Length:=13).Font
.Name = 'Arial'
.FontStyle = 'Gras'
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 11
End With
' Insertion colonne Designation sur l'onglet Câble>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Sheets('Câble').Select
Columns('E:E').Select
Selection.Insert Shift:=xlToRight
Range('E1').Select
ActiveCell.FormulaR1C1 = 'Designation'
With ActiveCell.Characters(Start:=1, Length:=13).Font
.Name = 'Arial'
.FontStyle = 'Gras'
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 11
End With
Sheets('Chaîne de mesure').Select
Range('A1').Select
nbf = MonWk.Sheets.Count
'sauve le nombre de feuilles présentes
For i = 1 To Worksheets.Count
Worksheets(i).Activate
' insertion 3 colonnes en A B et C pour y placer les données>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Columns('A:A').Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
'recherche champ Repere, champ à rapatrier dans la colonne A>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Cells.Find(What:='Repere', After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Range('A1').Select
ActiveSheet.Paste
' recherche champ Designation, champ à rapatrier dans la colonne B>>>>>>>>>>>>>>>>>>>>>>>>>
Cells.Find(What:='Designation', After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Range('B1').Select
ActiveSheet.Paste
' recherche champ Repere Nature, champ à rapatrier dans la colonne >>>>>>>>>>>>>>>>>>>>>>>>
Cells.Find(What:='Nature', After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Range('C1').Select
ActiveSheet.Paste
' suppression des espaces dans les cellules
Dim c As Range
Application.ScreenUpdating = False
For Each c In ActiveSheet.UsedRange
c.Value = Application.Trim(c.Value)
Next
' positionnement cellule active en A1 et dimensionnement des colonnes traitées>>>>>>>>>>>>>
Columns('A:C').Select
Columns('A:C').EntireColumn.AutoFit
Range('A1').Select
Next
Worksheets(1).Activate
' Sauvegarde et quitte le fichier xls>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ActiveWorkbook.Save
MonExcel.Quit
Set objXL = Nothing
MsgBox 'Fin de la procédure.'
End Sub