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
| 'Sub WriteAccessTableToExcelBranchInfo(ByVal strTableName As String)
Sub WriteAccessTableToExcelBranchInfo()
Dim strTableName As String
strTableName = "tbl_BonEmplacement"
Dim strExcelTabName As String
strExcelTabName = "Micromarket Definition"
Dim strTransferFileName As String
strTransferFileName = "C:\Origin\TransferTool.xlsm"
Dim wbexcel As Excel.workBook
Dim wbExists As Boolean
Dim objSht As Excel.workSheet
Dim objRange As Excel.Range
Set objExcel = CreateObject("excel.Application")
objExcel.Visible = True
On Error GoTo Openwb
wbExists = False
' Set wbexcel = objExcel.Workbooks.Add
Set wbexcel = objExcel.Workbooks.Open(strTransferFileName, 0, False)
Set objSht = wbexcel.Worksheets(strExcelTabName)
objSht.Activate
wbExists = True
Worksheets(strExcelTabName).Range("C13:K3000").Clear
Set objRange = objSht.Range("C13")
objRange.Clear
' Stop
' I will put here tables
Set rst = CurrentDb.OpenRecordset(strTableName)
If (rst.RecordCount > 0) Then
cnt = 1
For Each fld In rst.Fields
' wks.Cells(1, cnt).value = fld.Name
cnt = cnt + 1
Next fld
Call objRange.CopyFromRecordset(rst, 4000, 26)
End If
rst.Close
Set rst = Nothing
wbexcel.Application.DisplayAlerts = False
' Stop
wbexcel.Save
wbexcel.Close
wbexcel.Application.Quit
Set objRange = Nothing
Set objSht = Nothing
Set wbexcel = Nothing
'.............................
' I here will deal with Exceptions
Openwb:
On Error GoTo 0
If Not wbExists Then
objExcel.Workbooks.Add
Set wbexcel = objExcel.ActiveWorkbook
Set objSht = wbexcel.Worksheets(strExcelTabName)
End If
' ...........................................
Dim XL As Object
Set XL = CreateObject("Excel.Application")
XL.Workbooks.Open "C:\Origin\BranchNetTransferTool.xlsm"
XL.Run "AppendOnly"
'...........................................
End Sub |
Partager