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
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
| Private Sub Laquage_Click()
'Microsoft Excel xx.x Object Library
On Error GoTo ErrorHandler
Dim dbs As DAO.Database, rst As DAO.Recordset, rst1 As DAO.Recordset
Dim xlApp As Excel.Application, xlWbk As Excel.Workbook, xlWsh As Excel.Worksheet
Dim i As Integer, j As Integer, k As Integer, l As Integer, fldCount As Integer
Dim strFilePath As String, strBackSlash As String, strFolder As String, strFileName As String, strSheetName As String, strExt As String, strTableName As String
Dim strKill As String
'xlApp.Visible = True
strFilePath = CurrentProject.Path
strBackSlash = "\"
strFileName = "Laquage" ' nom fichier Xl
strSheetName = "Feuil1" ' nom feuille de calculs
strExt = ".xlsx"
strTableName = "T_Laquage" ' nom de la tbl
strFilePath = strFilePath & strBackSlash & strFileName & strExt
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strTableName)
If rst.EOF Then
MsgBox "il n'y a pas d'enregistrements !"
rst.Close
Set rst = Nothing
Exit Sub
End If
Set xlApp = New Excel.Application
xlApp.Visible = True
If xlWbk Is Nothing Then
Set xlWbk = xlApp.Workbooks.Open(strFilePath)
End If
Set xlWsh = xlWbk.Worksheets(strSheetName)
xlApp.ScreenUpdating = False
xlApp.EnableEvents = False
xlApp.DisplayAlerts = False
With xlWsh
.Range("J2:AA27").ClearContents
.Range("B16:D18").ClearContents
End With
fldCount = rst.Fields.Count ' nombre de champs tbl_laquage_tmp = 18 OK
With xlWsh
i = 10 ' indice colonne J
For j = 0 To fldCount - 1
.Cells(1, i).Value = rst.Fields(j).Name ' création des en-têtes dans Xl
i = i + 1
Next j
End With
With xlWsh
k = 2 ' indice ligne 2
Do Until rst.EOF
.Range("J" & k).Value = rst.Fields("NumOrigine").Value
.Range("K" & k).Value = rst.Fields("Numero").Value
.Range("L" & k).Value = rst.Fields("NumArticle").Value
.Range("M" & k).Value = rst.Fields("CodeVariante").Value
.Range("N" & k).Value = rst.Fields("DateCommande").Value
.Range("O" & k).Value = rst.Fields("DateLivDemander").Value
.Range("P" & k).Value = rst.Fields("QteManquante").Value
.Range("Q" & k).Value = rst.Fields("QteRestante").Value
.Range("R" & k).Value = rst.Fields("QtePretDepart").Value
.Range("S" & k).Value = rst.Fields("PoidsManquant").Value
.Range("T" & k).Value = rst.Fields("Observations").Value
.Range("U" & k).Value = rst.Fields("NomDestinataire").Value
.Range("V" & k).Value = rst.Fields("NumDestination").Value
.Range("W" & k).Value = rst.Fields("Choix").Value
rst.MoveNext
k = k + 1
Loop
End With
'Set rst1 = dbs.OpenRecordset(strTableName)
'With xlWsh
' l = 17 ' indice ligne 16
' Do Until rst1.EOF
' .Range("C" & l).Value = rst1.Fields("Reference_tmp").Value
' .Range("D" & l).Value = rst1.Fields("Traitement_tmp").Value
' .Range("E" & l).Value = rst1.Fields("Longueur_tmp").Value
' rst1.MoveNext
' l = l + 1
' Loop
'End With
'With xlWsh
' .Range("J1:AA10").Columns.AutoFit
'End With
xlWbk.Save
xlWbk.Close
Set xlWbk = Nothing
xlApp.Quit
Set xlApp = Nothing
CurrentDb.Execute "DELETE FROM T_Laquage "
If Not (rst Is Nothing Or rst1 Is Nothing) Then
rst.Close
rst1.Close
End If
dbs.Close
Set rst1 = Nothing
Set rst = Nothing
Set dbs = Nothing
ExitHandler:
Exit Sub
ErrorHandler:
MsgBox "Oups ! Une erreur a été rencontrée :" & vbCrLf & "Error " & Err.Number & ": " & Err.Description
Resume ExitHandler
Set xlWbk = xls.Workbooks.Open("C:\Users\ALTERNANT\Desktop\Laquage.xlsx")
Set xlWsh = wk.Sheets("Feuil1")
xlWsh.Activate
xlApp.Visible = True
Exit Sub
errHnd:
MsgBox "Erreur N° " & Err.Number & vbLf & Err.Description, , Err.Source
End Sub |
Copier contenu d'une table vers Excel à un endroit précis
Répondre avec citation
Envoyé par william.rodde
y-a-t-il toujours le même nombre de caractères avant LA (7)? Même question pour après LA (4)?
Partager