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 134 135 136 137 138
|
Public Sub ProcExportExcel(onglet)
Dim xlApp As Excel.Application 'Appli Excel
Dim oWkb As Excel.Workbook 'Classeur
Dim oWSht As Excel.Worksheet 'Feuille de Calcul
Dim Cell As Range
Dim ligne As Long
Dim col1 As Integer
Dim col2 As Integer
Dim col3 As Integer
Dim col4 As Integer
Dim col5 As Integer
Dim lignetrouvee, mc As Range
Dim bd As DAO.Database
Set bd = CurrentDb
Dim RecSet As DAO.Recordset
Dim cSQL As String
Dim NumInsert As String
Dim NumInsertCell As Range
Dim Num_Arch As String
Dim V_ADRESS_DOSS As String
Dim DM As String
Dim Empl As String
Dim ind_onglet As Variant
Dim Choix_ligne As String
Dim Num_ligne As Integer
Dim Msg As String
Dim Title As String
Dim Response
Dim Rep As Boolean
Dim Style As Variant
Dim Adre As String
Dim NonVide As Range
Set xlApp = CreateObject("Excel.Application")
cSQL = "SELECT N°Insertion,NUM_Archives,Adress_Doss, TAB_DM.DM,TAB_DM.EMPLACEMENT " & _
"FROM TAB_INSERTIONS INNER JOIN TAB_DM ON TAB_INSERTIONS.DM = TAB_DM.DM " & _
"WHERE Tab_DM.DM ='" & Forms!F_Ges_DM!Liste9 & "'" & "" & _
"ORDER BY Tab_Insertions.Date_Trait DESC,Tab_Insertions.N°Insertion;"
Set RecSet = bd.OpenRecordset(cSQL)
With xlApp
Set oWkb = xlApp.Workbooks.Open(DLookup("[Chemin_Fichier_Export]", "TAB_PARAMETRE") & DLookup("[Nom_Fichier_Export]", "TAB_PARAMETRE"))
For Each oWSht In oWkb.Sheets
If oWSht.Name = onglet Then
ind_onglet = oWSht.index
Exit For
End If
Next
On Error GoTo Ges_Err
ligne = 2
col1 = 1
col2 = 2
col3 = 3
col4 = 4
col5 = 5
Num_ligne = 2
Choix_ligne = "A" & Num_ligne & ":E" & Num_ligne & ""
Set NonVide = Worksheets(1).Range("G1")
RecSet.MoveFirst
With Worksheets(1).Range("A2:A2000")
If NonVide.Value > 0 Then
Msg = "Le Fichier d'Export est déjà utilisé. Voulez-vous continuer ?"
Style = vbYesNo + vbQuestion + vbDefaultButton1
Title = "Export Excel "
' Response = MsgBox(Msg, Style, Title)
If Not Rep Then Response = MsgBox(Msg, Style, Title)
Rep = True
End If
End With
Do While Not RecSet.EOF
If IsEmpty(Response) Or Response = vbYes Then
NumInsert = RecSet.Fields("N°Insertion")
Num_Arch = RecSet.Fields("NUM_Archives")
If Not IsNull(RecSet.Fields("Adress_Doss")) Then
V_ADRESS_DOSS = RecSet.Fields("Adress_Doss")
End If
DM = RecSet.Fields("DM")
Empl = RecSet.Fields("Emplacement")
With ActiveSheet
oWSht.Cells(ligne, col1).Select
oWSht.Cells(ligne, col1).Value = NumInsert
oWSht.Cells(ligne, col2).Select
oWSht.Cells(ligne, col2).Value = Num_Arch
oWSht.Cells(ligne, col3).Select
oWSht.Cells(ligne, col3).Value = V_ADRESS_DOSS
oWSht.Cells(ligne, col4).Select
oWSht.Cells(ligne, col4).Value = DM
oWSht.Cells(ligne, col5).Select
oWSht.Cells(ligne, col5).Value = Empl
End With
ligne = ligne + 1
Num_ligne = Num_ligne + 1
Choix_ligne = "A" & Num_ligne & ":E" & Num_ligne & ""
If Not RecSet.EOF Then
RecSet.MoveNext
End If
Else
RecSet.MoveNext
End If
Loop
If IsEmpty(Response) Or Response = vbYes Then
MsgBox "Export réussi... ", _
vbOKOnly, _
"Export Excel "
End If
' Sauvegarder et fermer le classeur
oWkb.Save
oWkb.Close
' Quitter Excel
.Quit
' Libérer les variables objet
Set oWSht = Nothing 'Feuille de Calcul
Set oWkb = Nothing 'Classeur
Set xlApp = Nothing 'Excell
FinGes_err:
Exit Sub
Ges_Err:
If err = 9 Then MsgBox "Attention ! Onglet " & onglet & " n'existe pas dans le fichier Export Prière d'en informer les Référents ", _
vbOKOnly + vbCritical, _
"Export Excel "
MsgBox err.Description & " " & err.Number
' Sauvegarder et fermer le classeur
If err <> 1004 Then
oWkb.Save
End If
If err <> 462 Then
oWkb.Close
End If
' Libérer les variables objet
' Quitter Excel
.Quit
End With ' Libérer les variables objet
Set oWSht = Nothing 'Feuille de Calcul
Set oWkb = Nothing 'Classeur
Set xlApp = Nothing 'Excell
Resume FinGes_err
End Sub |
Partager