Bonsoir,
A tout hasard je joins un fichier que qui permet d'importer tout ou partie des données d'un fichier, en se basant sur les valeur de cellule en tête de colonnes.
Aller voir la Sub CopyData pour les copies de feuilles complètes et les fonctions GetColumn ou GetColumns pour naviguer a travers les colonnes pour les imports partiels ou simplement si la position de la colonne désirée n'est pas connue...
Bonne nuit!
Private Sub CopyData(ByVal sFileFound As Variant) '(ByVal sFileFound As String)
Dim i As Long, j As Long, k As Long, i1 As Long, i2 As Long, n As Long
Dim TheRange As Range, TheCell As Range
Dim TheSearch As Object
Dim s As String
Dim oExcel As Excel.Application
Dim oWB(1 To 2) As Workbook '1: source, 2:destination
Dim oWS(1 To 2) As Worksheet '1: source, 2:destination
Dim WS As Worksheet
'Initialization
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
'Importing sequentially in the sheet names with same names (much smoother and easier)
n = UBound(sFileFound, 1) '+1
For i = 1 To n
Set oWB(2) = ActiveWorkbook
Set oExcel = New Excel.Application
oExcel.Visible = False: oExcel.DisplayAlerts = False
Set oWB(1) = oExcel.Workbooks.Open(CStr(sFileFound(i)), UpdateLinks:=False, ReadOnly:=True)
For Each WS In oWB(1).Worksheets
s = WS.Name
Set oWS(1) = oWB(1).Sheets(s) 'The raw data file from Outlook
' If s = "Report 1" Then s = DBDERIV.Name
' If s = "DATA" And oWB(1).Sheets.Count = 1 Then s = XRATES.Name
Set oWS(2) = oWB(2).Sheets(s) 'Same sheet name in the activeworkbook
oWS(2).Cells.ClearContents
'Copy the data
j = oWS(1).UsedRange.Columns.Count
k = oWS(1).UsedRange.Rows.Count
i1 = 1: i2 = 1
For k = 1 To oWS(1).UsedRange.Rows.Count
If k Mod 10 = 0 Then 'Copy by bulk of 10 rows to avoid a memory error
i2 = k
oWS(2).Range(oWS(2).Cells(i1, 1), oWS(2).Cells(i2, j)).Value = oWS(1).Range(oWS(1).Cells(i1, 1), oWS(1).Cells(i2, j)).Value
i1 = k + 1: i2 = k + 1
End If
Next k
If k >= i1 Then 'If there is at least one row to copy
i2 = k 'Copy the remaining rows
oWS(2).Range(oWS(2).Cells(i1, 1), oWS(2).Cells(i2, j)).Value = oWS(1).Range(oWS(1).Cells(i1, 1), oWS(1).Cells(i2, j)).Value
End If
Next WS
'Close all Excel instances and object memory allocations
oWB(1).Close savechanges:=False
Set oExcel = Nothing
For j = 1 To 2
Set oWB(j) = Nothing
Set oWS(j) = Nothing
Next j
Next i
'Finished
Application.Calculation = xlAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub