Erreur définie par l'Application ou par l'Objet (N°1004)

**xeron33** · 30/11/2020, 15h34

Bonjour à tous,
J'ai besoin d'exporter des données Access 2010 vers Excel 2010, sur ma base Access j'ai défini un bouton permettant sur l'évènement "sur click" de faire un export d'une table vers un classeur excel :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Public Sub ProcExportExcel(onglet)
Dim xlApp As Object 'Application Excel
Dim oWkb As Object 'Classeur
Dim oWSht As Object  '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 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
' Créer un objet Excel' (ce qui équivaut à démarrer Excel à distance)
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 & ""
RecSet.MoveFirst
Set lignetrouvee = oWSht.Range("A2:A2000").Find(Not Null, lookat:=xlPart)
Do While Not RecSet.EOF Or lignetrouvee Is Nothing
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")
             Cells(ligne, col1).Select     
             Cells(ligne, col1).Value = NumInsert    
             Cells(ligne, col2).Select
             Cells(ligne, col2).Value = Num_Arch
             Cells(ligne, col3).Select
             Cells(ligne, col3).Value = V_ADRESS_DOSS
             Cells(ligne, col4).Select
             Cells(ligne, col4).Value = DM
             Cells(ligne, col5).Select
             Cells(ligne, col5).Value = Empl
 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
Loop
' 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
        oWkb.Save
        oWkb.Close
       ' 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

Ce code fonctionne bien sur le 1er clic mais quand je veux refaire un export (2ème clic) j'ai l'erreur "Erreur définie par l'Application ou par l'Objet " (n°1004)
L'erreur se situe sur la ligne 62 en rouge
Si quelqu'un a une idée
Merci

**nico84** · 30/11/2020, 20h28

Bonjour,

Personnellement je précise toujours la feuille quand j'utilise la fonction cell, par exemple :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
with activesheet
 .cells(...
end with

**xeron33** · 04/12/2020, 14h50

Envoyé par nico84

Bonjour,

Personnellement je précise toujours la feuille quand j'utilise la fonction cell, par exemple :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
with activesheet
 .cells(...
end with

**************************************
Bjr et merci pour ta réponse j'ai essayé et non ca change rien

Merci

**tee_grandbois** · 04/12/2020, 15h17

bonjour,

Bjr et merci pour ta réponse j'ai essayé et non ca change rien

on aurait bien aimé malgré tout voir le nouveau code ...
étant donné que la feuille active est définie ici : For Each oWSht In oWkb.Sheets j'opterai plutôt pour:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
oWSht.Cells(ligne, col1).Select 
oWSht.Cells(ligne, col1).Value = NumInsert

**xeron33** · 16/12/2020, 15h31

Envoyé par tee_grandbois

bonjour,

on aurait bien aimé malgré tout voir le nouveau code ...
étant donné que la feuille active est définie ici : For Each oWSht In oWkb.Sheets j'opterai plutôt pour:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
oWSht.Cells(ligne, col1).Select 
oWSht.Cells(ligne, col1).Value = NumInsert

*****************************************************
Merci ca marche !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
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 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
' Créer un objet Excel' (ce qui équivaut à démarrer Excel à distance)
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 & ""
RecSet.MoveFirst
Set lignetrouvee = oWSht.Range("A2:A2000").Find(Not Empty, lookat:=xlPart)
Do While Not RecSet.EOF And lignetrouvee Is Nothing
 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
Loop
MsgBox "Export réussi... ", _
     vbOKOnly, _
     "Export Excel "
' 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
        oWkb.Save
        oWkb.Close
       ' 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

A +

Erreur définie par l'Application ou par l'Objet (N°1004)

VBA Access

Discussions similaires

Partager

Partager