Réunir les feuilles des autres fichiers excel dans un seul

**P96O1004** · 03/03/2009, 11h50

Bonjour,

Mes amis ont un soucis sur Excel. Ils connaissent rien du tout VBA donc j'essaie de faire quelque chose.

Voila, il y un certains fichiers excel de forme identique avec 7 feuilles toujours de forme identique dans un dossier.
Les noms des fichier sont en forme : "j*.chain.xls"
Il faut récupérer la feuille numéro 5 (nom : Global vision) de tout les fichiers et les mettre dans un fichier excel (nommé Coucou par exemple). Les feuilles sont renommées en "j*" (premier termes du nom de fichier)

De temps en temps, il y aura des fichiers en supplémentaire. Donc je pense à créer un fichier Database.xls. Je vais mettre un bouton : "Update" en feuil 1. Quand on click le bouton, il va récupérer les feuilles "Global vision".

En gros, au début j'ai : j1.chain.xls, j4.chain.xls, j100.chain.xls ..
Après j'ai un fichier coucou.exel avec feuille numéro 2 est j1, 3 est j4, 4 est j100 ....

Je connais un peu VBA, mais j'ai du mal à commencer. J'ai pensé un logarithme :

1 : Je modifie code pour changer l'adresse
2 : lister les fichiers qui ont "chain.xls" dans le nom.
3 : un boucle :
+ pour chaque fichier récupérer le premier termes du nom
+ copier le feuille "Global vision"
+ renommer le et coller dans la feuille numéro 2 de coucou.xls
(continuer coller les autres feuilles "Global vision" dans les feuilles numéro 3, 4, 5... de coucou.xls)
Voilà le code : (partie rouge est celle je suis bloqué)

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
Sub collect()
Dim wsT As Worksheet
   Dim wsF As Worksheet
   Dim lRow(1) As Long
   Dim iCol As Integer
   Dim sFolderName As String
   Dim sFname As String
    
    ' insérer l'adresse de dossier
   sFolderName = "D:\documents and Settings\SESA117973\Desktop\Data base collection\"
    'chercher file
   
   sFname = Dir(sFolderName & "j*.xls")
   
   If sFname = vbNullString Then
      MsgBox "No .xls Files In" _
         & Chr(10) & Chr(10) _
         & sFolderName, vbInformation
      Exit Sub
   End If
   
   Set wsT = ThisWorkbook.Sheets("Resultats")
   Do Until sFname = vbNullString
      Workbooks.Open sFolderName & sFname
      Set wsF = Sheets("Global vision")
            For i = 2 To 40
                Sheets("Global vision").Copy After:=Sheets(i)
                ActiveSheet.Name = "Position " & i
                
            Next i

    
      ActiveWorkbook.Close False
      sFname = Dir
   Loop


End Sub

Merci bien

**ouskel'n'or** · 03/03/2009, 12h23

Jette un oeil ici, l'un des deux messages devrait correspondre à ta demande.
- Le premier exemple rassemble les feuilles de x classeurs dans un classeur unique
- Le second rassemble les feuilles de x classeurs dans une feuille unique

Bonne journée

**P96O1004** · 03/03/2009, 13h41

Merci bien Mod ouskel'n'or,
Ca avance !
Mais comment je peux récupérer le premier termes de nom du fichier pour ensuite changer le nom de feuil ?

**ouskel'n'or** · 03/03/2009, 14h32

Envoyé par P96O1004

Merci bien Mod ouskel'n'or,
Ca avance !
Mais comment je peux récupérer le premier termes de nom du fichier pour ensuite changer le nom de feuil ?

Où ça ? Je ne comprends pas ta question. Si c'est dans la boucle "For Each LaFeuille In CL2.Worksheets 'parcours du classeur à copier" LaFeuille contient le nom de chaque nouvelle feuille

Code :

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

1
2
For Each LaFeuille In CL2.Worksheets
    Msgbox LaFeuille.name ' te le montrera

Je dois m'absenter, je te laisse en de bonnes mains

**P96O1004** · 03/03/2009, 15h56

Comme j'ai dit avant :
"En gros, au début j'ai : j1.chain.xls, j4.chain.xls, j100.chain.xls ..
Après j'ai un fichier Database.exel avec feuil numéo 1 est Update, feuil numéro 2 est j1, 3 est j4, 4 est j100 ...."

Donc il faut récupérer le premier termes de nom du fichier (nom fichier : j12.chain.xls, je récupère que j12) pour nommer les feuilles, car dans les fichiers j1, j12, j100, j.... le nom du feuil récupéré est toujours "Global vision".

Merci man,
En attendant ta réponse, j'appelle mon copain google.

**aalex_38** · 03/03/2009, 16h13

Bonjour P96O1004, bonjour à tous,

Mais comment je peux récupérer le premier termes de nom du fichier

Je ferrai quelque chose comme ça :

Code :

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

1
2
3
4
5
6
7
8
Sub esssai()
 
MyStr = "J34.xls"
MyStr = Mid(MyStr, 1, InStr(1, MyStr, ".", vbBinaryCompare) - 1)
 
Debug.Print MyStr
 
End Sub

Edit : dans cet exemple on prend tous les caractères jusqu'au premier point.

**P96O1004** · 05/03/2009, 10h36

J'ai trouvé ça pour supprimer tous les feuilles sauf feuille 1 (feuille "Update") avant collecter les feuilles :

Code :

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

1
2
3
4
5
6
7
Application.DisplayAlerts = False
 For Each Feuille In Worksheets
     If (Feuille.Name <> "Update") Then
        Feuille.Delete
     End If
 Next
Application.DisplayAlerts = True

Comment le modifier pour il puisse supprimer toutes les feuilles à partir feuille 2.
Parce que si quelqu'un modifie nom du feuille 1, c'est catastrophique.

Merci

**P96O1004** · 05/03/2009, 11h04

J'ai trouvé ca qui marche pour les autres sauf moi :

Code :

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

1
2
3
4
5
Application.DisplayAlerts = False
For compteur = 2 To Sheets.Count
    Sheets(compteur).Delete
Next compteur
Application.DisplayAlerts = True

En effet, il supprimer toutes les feuilles sauf feuilles 1, 2 et il affiche un bug.
Si je relance le macro, il supprime le feuille 2 comme je veux et le macro marche bien.

c'est bizarre non ?

**aalex_38** · 05/03/2009, 12h03

Bonjour,

Pour ta question du 03/03/2009 15h56 as-tu réussi à mettre en place ce que tu veux ?

Comment le modifier pour il puisse supprimer toutes les feuilles à partir feuille 2.
Parce que si quelqu'un modifie nom du feuille 1, c'est catastrophique.

Admettons que tu mettes en place ce code, que se passera-t-il si quelqu'un déplace la feuille ?

Edit : Peut être faudrait-il passer par une protection du classeur.

**ouskel'n'or** · 05/03/2009, 12h11

Teste en partant du haut

Code :

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

1
2
3
For i = Sheets.Count to 2 step -1
     Sheets(i).Delete
Next

**P96O1004** · 05/03/2009, 13h00

Envoyé par ouskel'n'or

Teste en partant du haut

Code :

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

1
2
3
For i = Sheets.Count to 2 step -1
     Sheets(i).Delete
Next

OMG, It runs very well.
I want to be like you someday.

**P96O1004** · 05/03/2009, 13h01

Envoyé par aalex_38

Bonjour,

Pour ta question du 03/03/2009 15h56 as-tu réussi à mettre en place ce que tu veux ?

Admettons que tu mettes en place ce code, que se passera-t-il si quelqu'un déplace la feuille ?

Edit : Peut être faudrait-il passer par une protection du classeur.

Merci beaucoup man,

Je vais chercher sur google comment protéger le classeur 1.

**P96O1004** · 05/03/2009, 15h03

To aalex_38 : je suis coincé. Si je bloque le classeur au niveau structure, macro ne peut pas ajouter des feuilles. Si non, l'utilisateur peut modifier le nom ou déplacer ma feuille "Update".

**aalex_38** · 05/03/2009, 15h24

Re,

La solution je pense, est de déprotéger et reprotéger par macro, un post récent ici

**ouskel'n'or** · 05/03/2009, 15h39

Tu as une option qui permet de protéger la structure. Regarde à "Méthode Protect" telle qu'elle s'applique à l'objet Workbook dans l'aide en ligne (F1)

Envoyé par l'aide en ligne

Structure Argument de type Variant facultatif. Cet argument a la valeur True pour protéger la structure du classeur (position relative des feuilles). La valeur par défaut est False.

**P96O1004** · 06/03/2009, 15h52

Merci chef, je vais tester et si ça marche je vais poster les codes ce soir.

Je profite pour demander une autre bugs concernant plusieurs condition avec IF

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
 
Sub filter()
        i = 3
        j = 2
            While Not IsEmpty(Sheets("DATA Import").Range("D" & i).Value)
                            If UCase(Sheets("DATA Import").Range("D" & i)) Like "*CAB*" Or UCase(Sheets("DATA Import").Range("D" & i)) Like "*GAS*" Or UCase(Sheets("DATA Import").Range("D" & i)) Like "*WIR*" Or UCase(Sheets("DATA Import").Range("D" & i)) Like "*PVC*" Or UCase(Sheets("DATA Import").Range("D" & i)) Like "*FOA*" Or UCase(Sheets("DATA Import").Range("D" & i)) Like "*THER*" Or UCase(Sheets("DATA Import").Range("D" & i)) Like "*EPD*" Then
                                            Sheets("DATA Import").Range("A" & i & ":AE" & i).Copy
                                            Sheets("DATA Filter").Range("A" & j).PasteSpecial Paste:=xlPasteAll
                                            j = j + 1
 
                            End If
                            i = i + 1
            Wend
 
End Sub

en effet je veux récupérer les lignes qui contient un des mots donnés dans le code. Mais quand je veux ajouter une autre condition : la ligne ne contient pas "*NYL*", il BUG. Le Not Like ne marche pas.

J'ai lu il y a d'autre choix que IF, mais j'arrive pas à comprendre comment les utiliser.

**P96O1004** · 11/03/2009, 10h13

J'ai perdu la connexion d'internet depuis presque une semaine.
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
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
 
Sub collect()
Dim wsT As Worksheet
   Dim wsF As Worksheet
   'Dim tWB As Workbook
   Dim sFolderName As String
   Dim sFname As String
   Dim wName As String
   Dim folderaddress$
 
Sheets("Update").Protect "xxxx"
 
Application.DisplayAlerts = False
For i = Sheets.Count To 2 Step -1
     Sheets(i).Delete
Next
 
Application.DisplayAlerts = True
folderaddress = "Please insert address of your folder without '\' at the end"
wName = ThisWorkbook.Name
sFolderName = InputBox(folderaddress, "Insert Address BOX")
sFolderName = sFolderName & "\"
If sFolderName = "\" Then
    MsgBox "No address insert !"
    Exit Sub
End If
 
sFname = Dir(sFolderName & "j*.xls")
If sFname = vbNullString Then
   MsgBox "No .xls Files In" _
      & Chr(10) & Chr(10) _
      & sFolderName, vbInformation
   Exit Sub
End If
 
 
Application.ScreenUpdating = False
Set wsT = ThisWorkbook.Sheets("Update")
   Do Until sFname = vbNullString
            If SheetExists(sFname) = True Then
              Application.DisplayAlerts = False
              Sheets(sFname).Delete
            End If
 
            Workbooks.Open sFolderName & sFname
            Set wsF = Sheets("Global vision")
            wsF.Copy After:=wsT
            Set temp = Workbooks(wName).Sheets("Global vision")
            temp.Name = Mid(sFname, 1, InStr(1, sFname, ".", vbBinaryCompare) - 1)
           ' temp.Name = sFname
            Workbooks(sFname).Close False
            sFname = Dir
   Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
 
 
End Sub
 
Function SheetExists(SName As String, _
                     Optional ByVal WB As Workbook) As Boolean
    On Error Resume Next
    If WB Is Nothing Then Set WB = ThisWorkbook
    SheetExists = CBool(Len(Sheets(SName).Name))
End Function

C'est super si ce code peut être utile pour les autres.

Merci mod

**P96O1004** · 03/04/2009, 10h23

Je reviens à mon problème. Voici le code final :

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
Sub collect()
Dim ws As Worksheet
   Dim wsF As Worksheet
   Dim sFolderName As String
   Dim sFname As String
   Dim Name As String
   Dim tempName As String
   Dim folder address$
 
Sheets("Update").Protect "haigiap"
ActiveWorkbook.Unprotect "haigiap"
 
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
 
For Each Feuille In Worksheets
    If (Feuille.Name <> "Update") Then
       Feuille.Delete
    End If
Next
 
Application.DisplayAlerts = True
 
folder address = "Please insert address of your folder without '\' at the end"
wName = ThisWorkbook.Name
FolderName = InputBox(folder address, "Insert Address BOX")
Folder Name = Folder Name & "\"
 
If Folder Name = "\" Then
    ActiveWorkbook.Protect "hair giap"
    Exit Sub
End If
'Récupérer des fichiers excels
 
sF name = Dir(Folder Name & "j*.xls")
 
If Fname = vbNullString Then
   MsgBox "No .xls Files In" _
      & Chr(10) & Chr(10) _
      & Folder Name, vbInformation
   Exit Sub
End If
 
Application.ScreenUpdating = False
Set wsT = ThisWorkbook.Sheets("Update")
   Do Until Fname = vbNullString
      tempName = Mid(Fname, 1, InStr(1, Fname, ".", vbBinaryCompare) - 1)
      If Sheet Exists(temp Name) = True Then
        Application.DisplayAlerts = False
        Sheets(tempName).Delete 'supprimer les feuilles existantes
      End If
 
'récupérer la feuille global vision
      Workbooks.Open sFolderName & sFname
      Set wsF = Sheets("Global vision")
      wsF.Copy after:=wsT
      Set temp = Workbooks(wName).Sheets("Global vision")
      temp.Name = tempName
      Workbooks(sFname).Close False
      sFname = Dir
   Loop
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
ActiveWorkbook.Protect "haigiap"
 
End Sub
 
Function SheetExists(SName As String, _
                     Optional ByVal WB As Workbook) As Boolean
    On Error Resume Next
    If WB Is Nothing Then Set WB = ThisWorkbook
    SheetExists = CBool(Len(Sheets(SName).Name))
End Function

La problème est s'il y a centaine fichiers, il plante !!!
Les fichiers "j*.xls" dans la réalité sont assez lourds (600Ko à 1500Ko) et contiennent vba code. Les fichiers "j*.xls" joints sont les mêmes avec vba code mais sans données dedans, donc 55Ko.

Tous les conseils sont bienvenues !!!
Merci par avance

**ouskel'n'or** · 04/04/2009, 10h31

Prévois simplement un enregistrement séquentiel (tous les n fichiers) du fichier principal... si tu ne l'as pas déjà fait

**P96O1004** · 06/04/2009, 09h46

Merci beaucoup MOD ouskel'n'or

,
Mais j'ai eu du mal à dire au VBA "tout les 30 fois récupérer la feuille" de façon correct.
Je pense à "un truc" : diviser par 30 le nombre d'exécution et le comparer avec 0, si la condition est satisfaite, on enregistre le fichier.
C'est bien ou non Mod ?

Réunir les feuilles des autres fichiers excel dans un seul

Macros et VBA Excel

Discussions similaires

Partager

Partager