Problème 1-Importation 2-regarder une table 3-suppression

**diki971** · 26/06/2014, 14h42

code MODULE:

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
 Option Compare Database
Option Explicit
 
Sub ImportExcel( _
  ByVal strChemin As String, _
  ByVal varFeuilles As Variant, _
  ByVal blnNoms As Boolean, _
  ByVal strTable As String _
  )
 
  ' Déclaration des variables
  Dim strFeuille As Variant
 
  ' Est-ce que le classeur Excel existe ?
  If Dir(strChemin) = "" Then
    MsgBox "Le classeur ['" & strChemin & "] est introuvable.", vbExclamation
    Exit Sub
  End If
 
  ' Procédure d'importation
  For Each strFeuille In varFeuilles
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, _
      strTable, strChemin, blnNoms, strFeuille & "!"
  Next
 
  ' Un p'tit message pour terminer
  MsgBox "Opération terminée !", vbInformation
  Exit Sub
 
  On Error GoTo ImportExcelErr
 
ImportExcelErr:
  MsgBox "Erreur d'importation : " & err.Description, vbExclamation
  Exit Sub
End Sub

code fonction:

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
 Option Compare Database
Option Explicit
 
Function NbDeChamps(NomTable As String) As Integer
On Error GoTo err
Dim db As DAO.Database
Dim T As DAO.TableDef
Set db = CurrentDb
Set T = db.TableDefs(NomTable)
NbDeChamps = T.Fields.Count
err:
End Function

code sur évènement:

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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
Private Sub btImporteParticipant_DblClick(Cancel As Integer)
On Error GoTo Err_btImporteParticipant_Click
 
 
Dim Msg, empl As String
Dim Feuille As Variant
Dim Style, Reponse, Reponse2, Reponse3
 
    Dim Arr1 As Variant, Arr2 As Variant, rq1 As Variant, rq2 As Variant
    Dim Element_A_Sup As Variant
    Dim i As Long, j As Long, h As Long, deb As Long, deb2 As Long
    Dim strSql As String, strTable As String, strTable2 As String
    Dim cheminFichier As String
    Dim rs1 As DAO.Recordset, rs2 As DAO.Recordset
    Dim StatusMsg As String, varReturn As Variant, lCount As Long
    Dim strRegroupDefaultValue As String
 
    strSql = "SELECT Nom, Prenom, RaisonSociale FROM "
    strTable = "Participant"
    strTable2 = "CreateParticipant"
 
    rq1 = strSql & strTable & ";"
    rq2 = strSql & strTable2 & ";"
 
    cheminFichier = "C:\Users\kevin\Desktop\test5.xlsx"
 
Msg = "Voulez-vous vraiment ajouter des participants?"
Style = vbYesNo + vbDefaultButton2
 
Reponse = MsgBox(Msg, Style)
 
If Reponse = vbYes Then    ' User chose Yes.
 
 'Dim db As Database
 '   Dim LSQL As String
 '
 '   Set db = CurrentDb()
 '   LSQL = "SELECT Nom FROM CreateParticipant;"
 '
 '   db.Execute LSQL
 '
 '   MsgBox CStr(db.RecordsAffected) & " enregistrements insérés."
 
  ' Vidage de la table si nécessaire
  'If NbDeChamps(strTable2) <= 1 Then
  '  If MsgBox("Souhaitez-vous vider la table [" & strTable & "] avant l'importation ?", _
  '      vbQuestion + vbYesNo) = vbYes Then
  '      CurrentDb.Execute "DELETE * FROM [" & strTable & "];"
  '  End If
  'Else
 
    'empl = InputBox("Vous pouvez saisir ici l'emplacement du fichier." & vbCrLf & vbCrLf & _
    '"(Exemple:" & vbCrLf & vbCrLf & _
    '"''C:\Users\...\Desktop\FichierAExtraire.xlsx'')")
    'Reponse2 = MsgBox(empl & vbCrLf & vbCrLf & _
    '"Est-ce que c'est le bon emplacement", Style)
    '
    'While Reponse2 <> vbYes
    '    empl = InputBox("Vous pouvez saisir ici l'emplacement du fichier." & vbCrLf & vbCrLf & _
    '   "(Exemple:" & vbCrLf & vbCrLf & _
    '    "''C:\Users\...\Desktop\FichierAExtraire.xlsx'')")
    '    Reponse2 = MsgBox(empl, Style)
    'Wend
    'Feuille = Array(InputBox("Entrez le nom de la feuille."))
    'Reponse3 = MsgBox(Feuille(0), Style)
    'While Reponse3 <> vbYes
    '    Feuille = InputBox("Entrez le nom de la feuille.")
    '    Reponse3 = MsgBox(Feuille(0), Style)
    'Wend
    'MsgBox ("Vous allez extraire les participants!")
    '
    'If Reponse2 = vbYes Then
    '    If Reponse3 = vbYes Then
 
                 ImportExcel cheminFichier, "Participants list", True, strTable2
 
 
    '    End If
    'End If
 
    Set rs1 = CurrentDb.OpenRecordSet(strTable, dbOpenDynaset, dbReadOnly)
    Set rs2 = CurrentDb.OpenRecordSet(rq2, dbOpenDynaset, dbReadOnly)
 
    rs1.MoveFirst
    While Not rs1.EOF
        With rs1
            MsgBox CStr(rs1.Fields("Nom").SourceField)
            Arr1.Add (rs1.Fields("Nom") & rs1.Fields("Prenom") & rs1.Fields("RaisonSociale"))
        End With
        rs1.MoveNext
    Wend
    rs1.Close
 
    rs2.MoveFirst
    While Not rs2.EOF
        With rs2
            MsgBox (rs2.Fields("Nom") & rs2.Fields("Prenom") & rs2.Fields("RaisonSociale"))
            Arr2.Add (rs2.Fields("Nom") & rs2.Fields("Prenom") & rs2.Fields("RaisonSociale"))
        End With
        rs2.MoveNext
    Wend
    rs2.Close
 
    i = Arr1.Count
    j = Arr2.Count
    h = 0
 
    For deb = 0 To (i - 1)
        For deb2 = 0 To j - 1
            If Arr1(deb) = Arr2(deb2) Then
                Element_A_Sup(h) = Arr1(deb)
                h = h + 1
                MsgBox Str(Arr1(deb))
            End If
        Next deb2
    Next deb
'  End If
Else    ' User chose No.
    MsgBox ("Vous n'avez pas donné(e) suite à cette action!")
End If
 
Exit_btImporteParticipant_Click:
    Exit Sub
 
Err_btImporteParticipant_Click:
    MsgBox err.Description
    Resume Exit_btImporteParticipant_Click
 
End Sub

Bonjour,

j'ai un scripte qui doit en premier lieux importer un fichier excel dans ma BDA dans un table fait exprès pour ca, mais l'importation ne marche pas j'ai le message d'erreur suivant:

Imcompatible type

ce qui est pas normal car tout est identique!

le second message viens de mon recorset (si je met en commentaire l'importation):

Variable d'objet ou viable de bloc With non définie

et le troisième problème c'est pour faire en sorte que ca se supprime les enregistrments en double lorsque je compare ma table participant avec createparticipant

**diki971** · 26/06/2014, 15h08

Code :

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

1
2
3
4
5
6
7
8
9
10
11
    Feuille = Array("Participants list")
    'Reponse3 = MsgBox(Feuille(0), Style)
    'While Reponse3 <> vbYes
    '    Feuille = InputBox("Entrez le nom de la feuille.")
    '    Reponse3 = MsgBox(Feuille(0), Style)
    'Wend
    'MsgBox ("Vous allez extraire les participants!")
    '
    'If Reponse2 = vbYes Then
    '    If Reponse3 = vbYes Then
    ImportExcel cheminFichier, Feuille, True, strTable2

j'ai retiré de commentaire feuillle pour mettre le texte en dur de dans...
du coup ca remarche l'importation

mais pour le reste je calle toujours

j'ai un quatrième mtn dans le cas ou je veux vider la table provisoir "CreateParticipant" ne marche pas le code entier ci-dessous et plus bas encore juste la partie de supression:

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
Private Sub btImporteParticipant_DblClick(Cancel As Integer)
On Error GoTo Err_btImporteParticipant_Click


Dim Msg, empl As String
Dim Feuille As Variant
Dim Style, Reponse, Reponse2, Reponse3
    
    Dim Arr1 As Variant, Arr2 As Variant, rq1 As Variant, rq2 As Variant
    Dim Element_A_Sup As Variant
    Dim i As Long, j As Long, h As Long, deb As Long, deb2 As Long
    Dim strSql As String, strTable As String, strTable2 As String
    Dim cheminFichier As String
    Dim rs1 As DAO.Recordset, rs2 As DAO.Recordset
    Dim StatusMsg As String, varReturn As Variant, lCount As Long
    Dim strRegroupDefaultValue As String
    
    strSql = "SELECT Nom, Prenom, RaisonSociale FROM "
    strTable = "Participant"
    strTable2 = "CreateParticipant"
    
    rq1 = strSql & strTable & ";"
    rq2 = strSql & strTable2 & ";"
    
    cheminFichier = "C:\Users\kevin\Desktop\test5.xlsx"

Msg = "Voulez-vous vraiment ajouter des participants?"
Style = vbYesNo + vbDefaultButton2

Reponse = MsgBox(Msg, Style)

If Reponse = vbYes Then    ' User chose Yes.

   'Vidage de la table si nécessaire
  If NbDeChamps(strTable2) <= 0 Then
    If MsgBox("Souhaitez-vous vider la table [" & strTable & "] avant l'importation ?", _
        vbQuestion + vbYesNo) = vbYes Then
        CurrentDb.Execute "DELETE * FROM " & strTable & ";"
    End If
  Else

    'empl = InputBox("Vous pouvez saisir ici l'emplacement du fichier." & vbCrLf & vbCrLf & _
    '"(Exemple:" & vbCrLf & vbCrLf & _
    '"''C:\Users\...\Desktop\FichierAExtraire.xlsx'')")
    'Reponse2 = MsgBox(empl & vbCrLf & vbCrLf & _
    '"Est-ce que c'est le bon emplacement", Style)
    '
    'While Reponse2 <> vbYes
    '    empl = InputBox("Vous pouvez saisir ici l'emplacement du fichier." & vbCrLf & vbCrLf & _
    '   "(Exemple:" & vbCrLf & vbCrLf & _
    '    "''C:\Users\...\Desktop\FichierAExtraire.xlsx'')")
    '    Reponse2 = MsgBox(empl, Style)
    'Wend
    Feuille = Array("Participants list")
    
    ImportExcel cheminFichier, Feuille, True, strTable2
    End If
    
    Set rs1 = CurrentDb.OpenRecordSet(strTable, dbOpenDynaset, dbReadOnly)
    Set rs2 = CurrentDb.OpenRecordSet(rq2, dbOpenDynaset, dbReadOnly)
    
    rs1.MoveFirst
    While Not rs1.EOF
        With rs1
            MsgBox CStr(rs1.Fields("Nom").SourceField)
            Arr1.Add (rs1.Fields("Nom") & rs1.Fields("Prenom") & rs1.Fields("RaisonSociale"))
        End With
        rs1.MoveNext
    Wend
    rs1.Close
    
    rs2.MoveFirst
    While Not rs2.EOF
        With rs2
            MsgBox (rs2.Fields("Nom") & rs2.Fields("Prenom") & rs2.Fields("RaisonSociale"))
            Arr2.Add (rs2.Fields("Nom") & rs2.Fields("Prenom") & rs2.Fields("RaisonSociale"))
        End With
        rs2.MoveNext
    Wend
    rs2.Close
    
    i = Arr1.Count
    j = Arr2.Count
    h = 0
    
    For deb = 0 To (i - 1)
        For deb2 = 0 To j - 1
            If Arr1(deb) = Arr2(deb2) Then
                Element_A_Sup(h) = Arr1(deb)
                h = h + 1
                MsgBox Str(Arr1(deb))
            End If
        Next deb2
    Next deb
Else    ' User chose No.
    MsgBox ("Vous n'avez pas donné(e) suite à cette action!")
End If

Exit_btImporteParticipant_Click:
    Exit Sub

Err_btImporteParticipant_Click:
    MsgBox err.Description
    Resume Exit_btImporteParticipant_Click
  
End Sub

(en gras et rouge la ou ca bloque!)

supression:

Code :

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

1
2
3
4
5
6
7
   'Vidage de la table si nécessaire
  If NbDeChamps(strTable2) <= 0 Then
    If MsgBox("Souhaitez-vous vider la table [" & strTable & "] avant l'importation ?", _
        vbQuestion + vbYesNo) = vbYes Then
        CurrentDb.Execute "DELETE * FROM " & strTable & ";"
    End If
  Else

merci par avance de votre aide

Problème 1-Importation 2-regarder une table 3-suppression [AC-2010]

Access

Discussions similaires

Partager

Partager