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
|
Sub WriteAccessTableToExcelBranchInfo()
Dim strTableName As String
Dim strExcelTabName As String
Dim strTransferFileName As String
Dim objExcel As excel.Application
Dim wbExcel As excel.workBook
Dim objSht As excel.workSheet
Dim objRange As excel.Range
Dim wbExists As Boolean
On Error GoTo L_ErrWriteAccessTableToExcelBranchInfo
'Table, Fichier et chemin à passer en paramètre
strTableName = "tbl_BonEmplacement"
strTransferFileName = "Z:\Trash\dvp\TransferTool.xlsx"
strExcelTabName = "Micromarket Definition"
wbExists = IIf(Dir(strTransferFileName, 0) <> "", True, False)
Set objExcel = CreateObject("excel.Application")
With objExcel
.Visible = True
.DisplayAlerts = False
If wbExists Then
Set wbExcel = .Workbooks.Open(strTransferFileName, 0, False)
Else
Set wbExcel = .Workbooks.Add
With wbExcel
.Worksheets(1).Name = strExcelTabName
.SaveAs strTransferFileName
End With
End If
With wbExcel
Set objSht = .Worksheets(strExcelTabName)
objSht.Activate
'Adresse à passer en paramètre
Set objRange = objSht.Range("C13")
If wbExists Then
'plage à passer en paramètre
.Worksheets(strExcelTabName).Range("C13:K3000").Clear
objRange.Clear
End If
'd'où vienne les 4000 ?
Call CopyDataTable(strTableName, objRange, 4000)
.Close True
End With
'.Workbooks.Open "C:\Origin\BranchNetTransferTool.xlsm"
'.Run "AppendOnly"
.Quit
End With
On Error GoTo 0
L_ExWriteAccessTableToExcelBranchInfo:
Set objRange = Nothing
Set objSht = Nothing
Set wbExcel = Nothing
Set objExcel = Nothing
Exit Sub
L_ErrWriteAccessTableToExcelBranchInfo:
MsgBox Err.Description, 48, Err.Source
If Not objExcel Is Nothing Then
objExcel.Quit
End If
Resume L_ExWriteAccessTableToExcelBranchInfo
End Sub
Private Sub CopyDataTable(ByVal TargetTable As String, ByRef Target As excel.Range, ByVal MaxRows As Long)
Set rst = CurrentDb.OpenRecordset(TargetTable)
If (rst.RecordCount > 0) Then
cnt = 1
For Each fld In rst.Fields
cnt = cnt + 1
Next fld
Target.CopyFromRecordset rst, MaxRows, cnt
End If
rst.Close
Set rst = Nothing
End Sub |
Partager