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
|
Function Recup_Analyse(ByVal Lig As Long) As String
Dim Res As String, St As String, Dem As String, Serv As String, Proj As String, Ech As String, NLot As String
Dim DteEnrg As Date
Dim c As Range
Dim i As Byte
With Sheets("Formulaire")
Dem = .Range("C4").Value
Serv = .Range("C5").Value
Proj = .Range("C6").Value
DteEnrg = CDate(.Range("C7").Value)
Ech = .Range("B" & Lig).Value
NLot = .Range("C" & Lig).Value
Res = "',#" & DteEnrg & "#,'" & Dem & "','" & Serv & "','" & Proj & "','" & Ech & "','" & NLot
For Each c In .Range("D" & Lig & ": M" & Lig)
If c.Value = "O" Or c.Value = "o" Then
Res = Res & "','" & .Cells(4, c.Column).Value
i = i + 1
End If
Next c
End With
St = Application.Rept("','", 11 - i)
St = Left(St, Len(St) - 3)
Recup_Analyse = Res & St
End Function
'Procédure permettant de faire l'enregistrement des différentes données dans le fichhier base
Sub Enregistrement_Base()
Dim Cn As New ADODB.Connection
Dim Rst As New ADODB.Recordset
Dim Fichier As String, Feuille As String, strSQL As String
Dim NumEnrg As Long
Dim c As Range
'Définit le classeur fermé servant de base de données
Fichier = "P:\commun\Techniciens\F.ROLLIN\divers\Projet_DA\Base_Donnees_DA.xls"
'Nom de la feuille dans le classeur fermé
Feuille = "Base"
'--- Connexion ---
With Cn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
& Fichier & ";Extended Properties=""Excel 12.0;HDR=YES;"""
.Open
End With
'-----------------
'Définit la requête permettant de récupérer le dernier numéro d'enregistrement
strSQL = "SELECT Max([N_Enregistrement]) FROM [" & Feuille & "$]"
Set Rst = Cn.Execute(strSQL)
NumEnrg = IIf(IsNull(Rst(0)), 0, Rst(0))
Set Rst = Nothing
With Sheets("Formulaire")
For Each c In .Range("Reference")
If c.Value <> "" Then
'Définit la requête permettant d'écrire toutes les données.
NumEnrg = NumEnrg + 1
strSQL = "INSERT INTO [" & Feuille & "$] VALUES ('" & NumEnrg & Recup_Analyse(c.Row) & "')"
Cn.Execute strSQL
.Range("O" & c.Row).Value = NumEnrg
End If
Next c
End With
'--- Fermeture connexion ---
Cn.Close
Set Cn = Nothing
End Sub |
Partager