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
| Option Explicit
#Const IsLateBinding = True
Private Sub btnImportXL_Click()
On Error GoTo btnImportXL_Err
#If IsLateBinding Then
Dim xlApp As Object
Dim xlWbk As Object
Dim xlWst As Object
Set xlApp = CreateObject("Excel.Application")
#Else
'Early binding Nécessite Microsoft Excel xx.x Object Library
Dim xlApp As Excel.Application
Dim xlWbk As Excel.Workbook
Dim xlWst As Excel.Worksheet
Set xlApp = New Excel.Application
#End If
Dim strFilePath As String, strTableName As String, strSheetName As String
Dim strImportAddress As String, strImportSheetAddress As String
Dim shtCount As Long, i As Long, j As Long, lastRow As Long, lastCol As Long
Dim rngImport As Range
Dim StartTime As Double
strFilePath = "C:\Users\Desktop\backup\Nuova cartella\PatInail rev 3.xlsx"
strTableName = "PAT"
Set xlWbk = xlApp.Workbooks.Open(strFilePath)
shtCount = xlWbk.Worksheets.Count
StartTime = Timer
If shtCount = 1 Then Exit Sub
For i = 1 To shtCount
For j = 1 To shtCount - 1
If xlWbk.Worksheets(j).Name > xlWbk.Worksheets(j + 1).Name Then
xlWbk.Worksheets(j).Move After:=xlWbk.Worksheets(j + 1)
End If
Next j
Next i
For i = 1 To shtCount
Set xlWst = xlWbk.Worksheets(xlWbk.Worksheets(i).Name)
strSheetName = xlWst.Name
With xlWst
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rngImport = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
strImportAddress = WorksheetFunction.Substitute(rngImport.Address, "$", "")
strImportSheetAddress = strSheetName & "!" & strImportAddress
Call DoCmd.TransferSpreadsheet(acImport, 10, strTableName, strFilePath, True, strImportSheetAddress)
End With
Next i
MsgBox "durée du traitement: " & Timer - StartTime & " secondes"
btnImportXL_Exit:
On Error Resume Next
Set xlWst = Nothing
xlWbk.Close False
Set xlWbk = Nothing
xlApp.Quit
Set xlApp = Nothing
Exit Sub
btnImportXL_Err:
MsgBox Err.Description, , "Erreur " & Err.Number
Resume btnImportXL_Exit
End Sub |