Séparer des feuilles excel pour les répartir dans des dossiers

**many6976** · 26/06/2013, 16h19

Salut tout le monde!

Dans le cadre d'un stage (en mécanique.. HAHA), on m'a demandé de créer une base de données.
Sans préciser plus le sujet du projet, je vais vous expliquer mon souci.

Nous utilisons CATIA, avec de la conception paramétrique. Pour ceux qui ne connaissent pas, ça veut dire qu'on fait un fichier 3D, par exemple une vis, auquel on joint un fichier Excel contenant des dimensions (une colonne diamètre, une colonne longueur, et donc par ligne un type de vis, et quand sur CATIA on sélectionne la ligne, la vis change de dimensions).

Le problème est que pour mon projet, je dois répartir tous les fichiers 3D dans des dossiers propres (un dossier par fichier) sachant qu'à l'origine, ils sont tous ensemble, et que leurs fichiers Excel sont fusionnés (par l'ancien stagiaire je crois).

Il faut donc répartir chaque worksheet dans un dossier, en prenant en compte que les noms ne correspondent pas toujours précisément, car la place est limitée pour les noms des worksheets

(et l'ancien stagiaire n'était pas des plus rigoureux...)
Par ex nom du fichier: ECROU CLUFIX HEXAGONALE TETE PLATE
nom de la worksheet: ECROU CLUFIX HEX. TETE PLATE

Vu le nombre de fichiers comme ça, j'aimerais faire une macro, sachant que j'ai déjà fait une macro pour créer les dossiers et mettre les fichiers 3D dedans, (et que j'ai commencé à faire de la VBA avant-hier... Vive les tutoriels )

Je sais pas si je suis très claire, mais bon

Enfin je vais bien sûr continuer de chercher, mais si quelqu'un pouvait m'aider, ce serait génial! (parce que je pourrais enfin faire de la méca u_u)

**many6976** · 26/06/2013, 21h17

Je me rends compte que mon message donne l'impression que je n'ai pas cherché...
J'ai pensé qu'il serait possible d'extraire des tableaux des noms de mes dossiers et des feuilles excel grâce à la fonction extractionMots de Silkyroad, et ainsi comparer 2 à 2 les éléments de ces tableaux, mais comme les noms ne sont pas strictement identiques, mais les premiers et derniers éléments normalement oui, peut-être que je pourrais juste comparer les premiers et derniers termes.

Mais il me reste le problème d'extraction des feuilles d'Excel.

**BlueMonkey** · 27/06/2013, 01h50

Salut,

Essaye en faisait une correspondance nom d'onglet de classeur / nom de dossier,
à partir d'une correspondance de syllabes.
Code à coller dans un module du classeurs Excel contenant toutes les feuilles à exporter.

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
 
'Nécessite l'ajout de la référence depuis le menu Option->Référence.
'Sélectionne la référence  : Microsoft Scripting Runtime
Option Explicit
 
Const MainDossier As String = "C:\Mon Dossier contenant les sous dossiers déjà créés "
Const SEPARATOR As String = " "
 
Sub CopieMesFeuillesDansMainDossier()
    Dim ListeSousDossier() As String
    GetSubFolders MainDossier, ListeSousDossier
    ExportWorksheetsToDossier ListeSousDossier
End Sub
 
Sub ExportWorksheetsToDossier(listeDossier() As String)
    Dim dossierDestination As String
    Dim ws As Worksheet
    For Each ws In Worksheets
        dossierDestination = FindFolder(Ucase(ws.name), listeDossier)
        If Len(dossierDestination) > 0 Then
            Dim wbToSave As Workbook
            ws.Copy
'           Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs MainDossier & "\" & dossierDestination & "\" & ws.name & ".xlsx"
            ActiveWorkbook.Close False
 '           Application.DisplayAlerts = True
        End If
    Next ws
End Sub
 
Function FindFolder(name As String, listeDossier() As String) As String
    Dim matchCount As Integer
    Dim bestMathCount As Integer
    Dim di As Integer
    For di = 1 To UBound(listeDossier)
        matchCount = GetCommunWordsCount(name, Ucase(listeDossier(di)))
        If matchCount > bestMathCount Then
            bestMathCount = matchCount
            FindFolder = listeDossier(di)
        End If
    Next di
 
End Function
 
Function GetCommunWordsCount(wd1 As String, wd2 As String) As Integer
    Const SEPARATOR As String = " "
    Dim w1Split() As String: w1Split = Split(wd1, SEPARATOR)
    Dim w2Split() As String: w2Split = Split(wd2, SEPARATOR)
    Dim splitCount As Integer
    splitCount = IIf(UBound(w1Split) < UBound(w2Split), UBound(w1Split), UBound(w2Split))
 
    GetCommunWordsCount = 0
    Dim wi As Integer
    For wi = 0 To splitCount
        If InStr(1, w1Split(wi), w2Split(wi)) > 0 Then
            GetCommunWordsCount = GetCommunWordsCount + 1
        End If
    Next wi
 
End Function
 
Sub GetSubFolders(dossierRacine As String, ByRef ListeSousDossier() As String)
    Dim fs As New FileSystemObject
    Dim dossier As Folder
    Dim di As Integer: di = 1
 
    With fs.GetFolder(dossierRacine)
        ReDim ListeSousDossier(.SubFolders.Count)
        For Each dossier In .SubFolders
            ListeSousDossier(di) = dossier.name
            di = di + 1
        Next dossier
    End With
 
    Set fs = Nothing
End Sub

**many6976** · 27/06/2013, 14h15

Salut,

Merci, BlueMonkey, ça m'aide beaucoup!
Je n'ai pas tout utilisé parce que si je comparais 3 mots des noms, ça ne marchait pas toujours, et si je ne comparais que 2 mots, ça ne suffisait pas toujours... Donc j'ai plutôt utilisé une extraction des noms, puis une comparaison du premier et dernier noms, ce qui - jusque-là - se compile.
Mais j'ai un souci avec (voir "=>"):

Code :

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

1
2
3
4
5
If (UBound(nom0) = UBound(nom1)) And (LBound(nom0) = LBound(nom1)) Then
     oWS.Copy
=>  ActiveWorkbook.SaveAs oFSO.GetAbsolutePathName(MonDossier) & "\" & oFSO.GetBaseName(MonFichier) & "\" & oWS.name & ".xlsx" 
      ActiveWorkbook.Close False
End If

Il me sort que Microsoft Excel ne peut accéder à ce fichier parce que:
Soit le nom du fichier ou le chemin n'existe pas, soit il est utilisé ailleurs.

Le chemin qu'il m'indique existe, et personne d'autre n'utilise ce fichier...

Ou alors j'ai peut-être pas compris ce passage de ton code

**BlueMonkey** · 27/06/2013, 15h38

Bonjour,

Je pense que "\" & oFSO.GetBaseName(MonFichier) et "\" & oWS.name fond double emploi pour le nom de fichier.
Essaye avec l'un ou l'autre dans la ligne :

Code :

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

ActiveWorkbook.SaveAs oFSO.GetAbsolutePathName(MonDossier) & "\" & oFSO.GetBaseName(MonFichier) &  ".xlsx"

ou

Code :

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

ActiveWorkbook.SaveAs oFSO.GetAbsolutePathName(MonDossier) & "\" &  oWS.name & ".xlsx"

A+

**many6976** · 27/06/2013, 17h56

Re-Salut,

En fait, je te montre l'adresse:
C:\Documents and Settings\mon_nom\Desktop\test\test.xls
C'est pour ça que ça apparaît deux fois, mon fichier Excel doit prendre le même nom que mon dossier, qui lui-même a le même nom que mon composant CATIA.

Au fait, je reviens sur le code que tu m'as envoyé, il y a un bout avec lequel je ne sais pas quoi faire:

Code :

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

Dim wbToSave As Workbook

Est-ce que j'ai raté quelque chose?

Quand j'exécute mon code, il ouvre un nouveau classeur mais celui que je veux copier s'ouvre en lecture seule. Je ne comprends pas pourquoi

Si t'as des réponses!

A+, bonne soirée!

**BlueMonkey** · 27/06/2013, 20h27

Bonsoir,

Pour le problème d'enregistrement, le dossier C:\Documents and Settings\ton_nom\Desktop\test\ existe ?
Le fichier doit être enregistré au format XLS2003 (xls) ou XLS2010 xlsx ?
Parceque dans le code on précise & ".xlsx".

Effectivement la ligne Dim wbToSave As Workbook ne sert plus à rien.
(c'était utilisé pour tester une solution intermédiaire, qui n'a pas été conservé dans la solution finalement postée).
Comme quoi, à 1h50 je n'ai plus les idées très claires ...

il ouvre un nouveau classeur mais celui que je veux copier s'ouvre en lecture seule.

Tu n'as peut être pas les droits en écriture sur le dossier dans lequel se trouve le fichier en question.
D'ailleurs ca peut aussi faire planter la macro d'enregistrement.
Sinon, regarde dans les propriétés du fichier sous Windows (clic droit -> Propriété),
et regarde s'il est en lecture seule.
Quoiqu'il en soit, le fichier peut être ouvert en lecture seule, mais enregistré sous un autre nom,
a condition de ne pas chercher à enregistrer dans un dossier où on a pas les droits en écriture.

**many6976** · 28/06/2013, 11h44

Argh, crotte de bique...

Tous les dossiers que je crée sur le dossier sont en lecture seule

J'ai envoyé un mail au service IT...
c'est con, parce que si je rentre dans le dossier, je peux créer ce que je veux comme fichier manuellement, supprimer à tout va, et déplacer... Quand j'ouvre mon fichier test, il me dit qu'il est déjà utilisé par mclozel (moi), et qu'il me notifiera quand il sera libéré... mais même quand je ferme le fichier dans lequel je fais ma macro, il reste en lecture seule.

hm, j'ai ouvert le gestionnaire des tâches après avoir fermé
Excel (toutes les instances visibles) et en fait ils en restaient d'ouvertes (tous les essais qui ne donnaient rien), mais que je ne peux pas voir.
Est-ce que tu sais pourquoi?

J'ai "presque" réussi pour mon test sur le bureau. Voici le code:

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
Dim extensname As String
Dim same As Integer, same2 As Integer, same3 As Integer
Dim oWS As Worksheet
Dim oWB As Workbook
Dim nom0 As String, nom1 As String, dest As String
Dim oFld0 As Folder, oFld1 As Folder
Dim oFSO As Scripting.FileSystemObject
Dim WB As Workbook, nWB As Workbook
Dim WS As Worksheet, nWS As Worksheet
Dim oExcel As Excel.Application
 
Sub TryWithTest()
 
    Set oFSO = New Scripting.FileSystemObject
    Set oFld0 = oFSO.GetFolder("C:\Documents and Settings\mclozel\Desktop\test")
 
    'On parcourt les sous-dossiers de "test"
    For Each oFld1 In oFld0.SubFolders
 
        'ouvre le fichier excel à répartir:
        Set oExcel = New Excel.Application
        path0 = oFSO.BuildPath("C:\Documents and Settings\mclozel\Desktop\test\", oFSO.GetBaseName(oFld0) & ".xls")
        Set WB = oExcel.Workbooks.Open(path0)
        nom0 = UCase(oFSO.GetBaseName(oFld1))
 
        'On parcourt les Feuilles du classeur
        For Each WS In WB.Worksheets
            nom1 = UCase(WS.Name)
 
            'on cherche la feuille correspondant au dossier en cours
            If (nom1 = nom0) Then
 
                'on crée un classeur au nom du dossier dans le dossier en cours
                dest = oFSO.BuildPath("C:\Documents and Settings\mclozel\Desktop\test", "\" & oFSO.GetBaseName(oFld1) & "\" & oFSO.GetBaseName(oFld1) & ".xls")
                Workbooks.Add.SaveAs dest
 
                'on y copie la feuille correspondante
                WS.Select
                WS.Copy Before:=Workbooks(dest).Sheet1 '<= c'est ici que ça coince, il me dit que l'indice n'appartient pas à la sélection. Je veux mettre ma copie en premier dans le nouveau classeur
 
                ActiveWorkbook.Close False
 
            End If
 
        Next WS
 
    Next oFld1
 
End Sub

Et pour désigner la première feuille, j'ai vu Sheets(1) et Sheet1, mais je ne connais pas la différence.

**BlueMonkey** · 28/06/2013, 12h56

Salut,

La ligne Set oExcel = New Excel.Application créé une nouvelle instance d'Excel qui est par défaut "non visible".
Si tu es déjà sous Excel, cette ligne est inutile.

Au lieu d'écrire oExcel.Workbooks.Open(path0), tu peux écrire Workbooks.Open(path0).
Mais si vraiment tu veux faire le traitement dans une nouvelle instance invisible d'Excel :

- sort la ligne Set oExcel = New Excel.Application de la boucle For Each oFld1 In oFld0.SubFolders,

- à la fin du traitement, ferme l'instance invisible, et libère la mémoire.

Code :

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

1
2
oExcel.Quit
Set oExcel = Nothing

Pour ce qui est de la séquence de code suivante :

Code :

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

1
2
3
4
5
Workbooks.Add.SaveAs dest
'on y copie la feuille correspondante
WS.Select
WS.Copy Before:=Workbooks(dest).Sheet1 '<= c'est ici que ça coince, il me dit que l'indice n'appartient pas à la sélection. Je veux mettre ma copie en premier dans le nouveau classeur
ActiveWorkbook.Close False

essaye comme ça

Code :

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

1
2
3
Workbooks.Add.SaveAs dest
WS.Copy Before:=ActiveWorkbook.Sheets(1)
ActiveWorkbook.Close False

A+

P.S : Lorsque tu poste du code, pense à le sélectionner puis à cliquer sur le boutton

pour avoir une mise en forme "code".

**many6976** · 28/06/2013, 13h47

oups, désolée pour la mise en page du code, je ne connaissais pas!

Et merci pour les explications de

Code :

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

Set oExcel = New Excel.Application

et tout, c'est vrai que j'ai fait beaucoup de copier-coller, et y'a certains trucs que j'ai mal compris...

Alors, ton code se compile parfaitement, mais Excel n'effectue pas la copie de ma worksheet

Pour les noms, pas de problèmes, mais y'a rien dans la feuille.
Donc a priori c'est

Code :

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

WS.Copy Before:=ActiveWorkbook.Sheets(1)

qui a un problème. Ce qui m'énerve c'est que s'il me donne pas d'erreur, je sais pas où chercher. Pourquoi n'aurait-il rien dans les feuilles?

~quelques minutes plus tard~

Mouhéhéhé C'est sûr que si je sauvegarde pas les changements quand je ferme mon ActiveWorkbook ça n'arrange rien!

Donc il fallait:

Code :

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