Discussion :

[webisfun]

Bonjour,
Je connais Excel et moins Vba, je ne maîtrise pas tout.
Pour faciliter mes traitements, j'ai mis tous les fichiers Excel (format.xlsx) dans le même répertoire et ils ont tous le même nom incrémenté.
On a 2 séries de fichiers : ceux contenant les données : FicData001.xlsx à FicDataxxx.xlsx et 27 fichiers vides qui vont recevoir les données extraites des FicDataxxx.xlsx. Ces 27 fichiers correspondent aux 26 lettres de l'alphabet + 1 pour tous les chiffres de 0 à 9. Ces fichiers vides sont nommés FicTriA.xlsx, FicTriB.xlsx...FicTriZ et enfin FicTri0.xlsx.

Les FicDataxxx ont tous une seule feuille portant toujours le même nom, le même entête de colonne et n'ont qu'une seule colonne A renseignée avec des noms triés de 0 à 9 puis de A à Z (tri normal de Excel).
Les FicTrix.xlsx ont tous aussi une seule Feuille avec une seule colonne et son entête.
C'est volontaire car tout regrouper dans un seul fichier avec des onglets créerait un fichier Excel de plusieurs centaines de Mo, et j'ai déjà plus d'une fois planté Excel avec de gros fichiers !

Ce que je voudrais faire :
1) Lire sans l'ouvrir le premier fichier FicDataxxx
2) Tester le premier caractère de chaque ligne (sans distinction minuscule/majuscule)
3) Extraire le contenu de chaque cellule
4) Tester si le contenu de cette cellule n'existe pas déjà (= sans doublon) dans le fichier FicTrix.xlsx correspondant sans avoir à l'ouvrir. (Ecriture dans la Feuille1 en colonne A à partir de la ligne 2)

ex : le premier enregistrement du fichier FicData001.xlsx est "AlainEtCécile". Premier caractère = "A". Donc j'écris "AlainEtCécile" dans le fichier FicTriA.xlsx si cette valeur n'y est pas déjà, sinon je ne fais rien.
Je boucle sur l'enregistrement suivant jusqu'à la fin puis sur le fichier suivant.

(Le petit plus sera d'ajouter un compteur de contrôle pour vérifier que le nombre d'enregistrements lus correspond bien au nombre d'enregistrements écrits + nombre de doublons)

J'ai bien réussi à trouver différentes portions de codes (notamment avec ADO) mais je n'arrive pas à les imbriquer correctement. Merci d'avance pour vos réponses.

[mercatog]

Bonjour
Proposition permettant de parcourir tous les fichiers FicDataxxx.xlsx.
De remplir un dictionnaire sans doublons des noms en colonne A.
De créer les fichier FicTriN correspondants
Et de transférer les données

PS, si les fichiers FicTriN existent déjà et ne sont pas vides, les données vont s'ajouter aux anciennes (avec risque de doublon)

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
Option Explicit
'===========================================
'/!\ ACTIVER LES REFERENCES:
' - Microsoft ActiveX Data Objects x.x Library
' - Microsfot Scripting Runtime
'===========================================
 
'=== Variables globales
Dim Chemin As String
Dim Dico As Scripting.Dictionary                 'Dictionnaire contenant tous les noms
Dim Db As Long                                   'Compteur de tous les éléments
 
'=== Sub de lancement
Sub Traitement()
Dim Fichiers() As String
Dim Fich As String
Dim i As Integer
 
Application.ScreenUpdating = False
Chemin = "C:\Users\user\Desktop\Exemple Webisfun\"    'N'oublie pas \ à la fin de Chemin
Fich = Dir(Chemin & "*.xlsx")
Set Dico = New Scripting.Dictionary
 
Do While Fich <> ""
    If Left(Fich, 7) = "FicData" Then Call RemplirDico(Chemin & Fich)
    Fich = Dir()
Loop
 
For i = 0 To Dico.Count - 1
    Transfert Dico.items(i)
Next i
MsgBox "Opération terminée sur " & Db & " éléments avec " & Dico.Count & " sans doublons"
Set Dico = Nothing
End Sub
 
'=== Sub permettant de remplir Dico par les valeurs sans doublons de toutes les données de la colonne A
 
Private Sub RemplirDico(ByVal FichSce As String)
Dim sSQL As String, Client As String
Dim Cn As New ADODB.Connection
Dim Rst As New ADODB.Recordset
Dim i As Integer
 
'--- Connection ---
With Cn
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FichSce & ";Extended Properties=""Excel 12.0;HDR=YES;"""
    .Open
End With
 
'--- Définit la requête ---
sSQL = "SELECT * FROM [Feuil1$]"                 '/!\ Attention à ne pas oublier le symbole $ après le nom de la feuille.
Set Rst = Cn.Execute(sSQL)
If Not Rst.EOF Then
    Rst.MoveFirst
    Do While Not Rst.EOF
        Client = Rst(0).Value
        If Len(Client) > 0 Then
            Db = Db + 1
            If Not Dico.Exists(UCase(Client)) Then Dico.Add UCase(Client), Client
        End If
        Rst.MoveNext
    Loop
End If
Rst.Close
Set Rst = Nothing
Cn.Close
Set Cn = Nothing
End Sub
 
'=== Sub permettant de transférer le Clien sur le fichier destination correspondant
'    Si le fichier n'existe pas, il le crée
 
Private Sub Transfert(ByVal Client As String)
Dim FichDest As String, dSQL As String
Dim Cnd As New ADODB.Connection
 
FichDest = "FicTri" & UCase(Left(Client, 1)) & ".xlsx"
Creation FichDest
 
'--- Connection ---
With Cnd
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FichDest & ";Extended Properties=""Excel 12.0;HDR=YES;"""
    .Open
End With
 
'--- Définit la requête ---
dSQL = "INSERT INTO [Feuil1$] " & "VALUES ('" & Client & "')"
Cnd.Execute dSQL
Cnd.Close
Set Cnd = Nothing
End Sub
 
'=== Sub de création du fichier destination s'il n'existe pas
 
Private Sub Creation(ByRef Fichier As String)
 
Application.ScreenUpdating = False
Fichier = Chemin & Fichier
If Dir(Fichier) = "" Then
    With Workbooks.Add(1)
        .Worksheets(1).Range("A1").Value = "Client"
        .SaveAs Filename:=Fichier, FileFormat:=xlOpenXMLWorkbook
        .Close False
    End With
End If
End Sub

[webisfun]

Bonjour et merci Mercatog,

Ca répond exactement à ma demande. Cependant ca fonctionne très bien tant que les fichiers ne sont pas très gros.
Après, je pense que le remplissage puis l'accès au dictionnaire prennent de plus en plus de temps.
Je vais créer 2 nouveaux messages. Je pense que celui-ci peut être clos même si je vais y faire référence en partie.