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
| Sub Prepaimport()
Dim i, j, k, m, yeari, monthi, dayi, yearj, monthj, dayj, lastline, test As Integer
Dim Dati, Datj As Date
Dim Lignememematr() As Variant
Dim Cn As ADODB.Connection
Dim FichierCSV, Dossier, datstr As String
Dim NomFeuille As String, text_SQL As String
Dim Rst As ADODB.Recordset
'On Error GoTo ADO_ERROR
Dossier = "C:\Users\2018_et_2019\" 'penser à terminer par un \
Set Cn = New ADODB.Connection 'connexion au dossier considéré comme base de données
Cn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Dossier & "; Extended Properties = ""text; HDR = No; IMEX =1""" '; FMT=Delimited"" ;Persist Security Info=False"
Cn.ConnectionTimeout = 40
Cn.Open
creationfichiershemaini 'Création du fichier ini
m = 2 'mise à jour
'Faire un tri adapté : matricule croissant, date entrée croissante, date sortie croissante
For i = 1 To Sheets("Feuil1").Cells(Columns(1).Cells.Count, 1).End(xlUp).Row 'boucle sur les lignes
j = i + 1
If i = 10 Or i = 830 Or i = 1000 Or i = 2000 Or i = 5000 Or i = 7000 Or i = 10000 Or i = 12000 Then
Debug.Print (i)
ThisWorkbook.Save
End If
While Sheets("Feuil1").Cells(j, 1).Value = Sheets("Feuil1").Cells(i, 1).Value 'Boucle sur matricule, isoler les lignes avec matricule
If Sheets("Feuil1").Cells(j - 1, 7).Value < Sheets("Feuil1").Cells(j, 6).Value Then 'vérifier trous d'affectation, si trou :
With Sheets("Feuil1")
yearj = Val(Left(.Cells(j, 6), 4)) 'Extraction de l'année, mois et date
monthj = Val(Mid(.Cells(j, 6), 6, 2))
dayj = Val(Mid(.Cells(j, 6), 9, 2))
Datj = CDate(monthj & "/" & dayj & "/" & yearj) 'Val(yearj & Format(monthj, "00") & Format(dayj, "00"))
yeari = Val(Left(.Cells(j - 1, 7), 4)) 'Extraction de l'année, mois et date
monthi = Val(Mid(.Cells(j - 1, 7), 6, 2))
dayi = Val(Mid(.Cells(j - 1, 7), 9, 2))
Dati = CDate(monthi & "/" & dayi & "/" & yeari) 'Val(yeari & Format(monthi, "00") & Format(dayi, "00"))
End With
For k = Dati To Datj 'boucle sur date, attention
datstr = year(k) & month(k) & day(k)
FichierCSV = Dir(Dossier & datstr & "*" & ".csv") 'recherche du fichier
If FichierCSV <> "" Then
'-----------------
text_SQL = "SELECT * FROM [" & FichierCSV & "] WHERE [cRefExt] LIKE " & Sheets("Feuil1").Cells(j, 1).Value & " ;" 'création de la requête avec vérif présence matricule
'Set Rst = New ADODB.Recordset 'Exécution de la requête
'Debug.Print (text_SQL)
Set Rst = Cn.Execute(text_SQL)
'mise à la ligne 2 pour ne pas avoir les en-têtes
'lastline = Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
Sheets("import").Cells(m, 2).CopyFromRecordset Rst 'Copie du recordset dans la première cellule videVariable() = Rst.Fields(0)
Sheets("import").Cells(m, 1) = k
m = m + 1
'Copie de tout le recordset, si il y a quelque chose, la ligne sera copié, si il n'y a rien, il n'y a pas besoin d'importer vu que la personne n'est pas dans les fichiers ce jour là
Rst.Close 'fermeture du recordset
Set Rst = Nothing
End If
'si présent : vérifier affectation
'si affectation bonne : ajouter à l'import
'si affectation différente : ajouter à l'import avec affectation différente
Next 'fin boucle date
End If 'fin si trou
j = j + 1
Wend 'fin boucle matricule
i = j - 1 ' remise à jour du numéro de ligne
Next 'fin boucle While Cells(j, 1).Value = Cells(i, 1).Value
'ADO_ERROR:
'If Err <> 0 Then
' Debug.Assert (Err = 0)
' MsgBox (Err.Description)
' Resume Next
'End If
Cn.Close 'fermeture du fichier
Set Cn = Nothing
End Sub |
Partager