Macro Excel

[Claude]

Bonjour,

Avec excel 2000 je souhaiterais faire la macro dont l'objectif est le suivant :

Dans un dossier, j'ai 1 certain nombre de fichier xls.
Chacun de ces fichiers comporte 1 à n feuilles
Ex :
a.xls --> Feuilles : F1 - F2 - F3
b.xls --> Feuilles : F1 - F4
c.xls --> Feuilles : F1 - F2 - F4

La macro aurait pour objet de générer les fichiers xls suiant :

F1.xls --> Feuilles : a - b - c
F2.xls --> Feuilles : a - c
F3.xls --> Feuilles : a
F4.xls --> Feuilles : b - c

Si quelqu'un peut m'aider !!
Merci d'avance.

 

[Zon]

Salut,

Si j'ai bien compris, F1=a , F4=d tu veux renommer les feuilles et les fichiers suivant cette logique.

Colles ceci dans un module standard

Const Chemin$ = "C:\lenomdurépertoire" 'adapter le nom du dossier

Sub Princ()
Dim ToR, TfiN, T, C As Workbook
Dim I&, J&, NumFich&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ToR = Array("a", "b", "c", "d")
TfiN = Array("F1", "F2", "F3", "F4")
T = ChercheFichier("*.xls", Chemin)
If IsArray(T) Then
For I = LBound(T) To UBound(T)
NumFich = TesteNomF(ToR, NomFichier(T(I)))
If NumFich > 0 Then
Set C = Workbooks.Open(T(I))
With C
For J = LBound(TfiN) To UBound(TfiN)
On Error Resume Next
Set F = .Sheets(TfiN(J))
If Err = 0 Then _
If Not F.ProtectionMode Then F.Name = ToR(F.Index) 'on renomme la feuille
Next J
.SaveAs Chemin & "\" & TfiN(NumFich) & ".xls" 'on change le nom de fichier en l'enregistrant
.Close
End With
' Kill T(I) 'On efface le fichier d'origine, ôter le commentaire aprés les tests
End If
Next I
Else: MsgBox T
End If
End Sub

Function ChercheFichier(NomF$, Rep$, Optional Sourep As Boolean = False)'Zon
Dim I&, Tablo
On Error Resume Next
With Application.FileSearch
.NewSearch
.LookIn = Rep
.Filename = NomF
.SearchSubFolders = Sourep
.Execute
ReDim Tablo(1 To .FoundFiles.Count)
For I = 1 To .FoundFiles.Count
Tablo(I) = .FoundFiles(I)
Next I
End With
On Error GoTo 0
ChercheFichier = IIf(I > 1, Tablo, "Pas de fichier trouvé " & Rep)
End Function

Function NomFichier$(ByVal Ch$, Optional Ext As Boolean = False) 'Zon
'Retrouver le nom de fichier avec ou sans son extension à partir de son chemin complet
While InStr(Ch, "\") > 0
Ch = Mid(Ch, InStr(Ch, "\") + 1)
Wend
NomFichier = IIf(Ext, Ch, Left(Ch, Len(Ch) - 4))
End Function

Function TesteNomF&(T, ByVal NomF$)
Dim I&
For I = LBound(T) To UBound(T)
If T(I) = NomF Then TesteNomF = I + 1: Exit For
Next I
End Function



A+++

 

[Zon]

Re,

J'ai fait une erreur, remplacer f Not F.ProtectionMode Then F.Name = ToR(F.Index) par f Not F.ProtectionMode Then F.Name = ToR(F.Index-1), Tor étant en base 0.

A+++

 

[Claude]

Merci beaucoup mais malheureusement le traitement ne fonctionne pas tout à fait, malgré la modif précisée dans votre second mail.
En effet j'ai :
Fichier a avec feuilles F1,F2,F3
Fichier b avec feuilles F1,F4
Fichier c avec feuilles F1,F2,F4

Au lieu d'obtenir
Fichier F1 avec feuilles a,b,c
Fichier F2 avec feuilles a,c
Fichier F3 avec feuille a
Fichier F4 avec feuilles b,c

J'obtiens :
Fichier F2 avec feuilles a,b,c
Fichier F3 avec feuilles a,b
Fichier F4 avec feuilles a,b,c

Si vous avez une idée ?
Merci encore

 

[Zon]

Salut,

L'autre soir j'aurais dû testé, ça ne sert à rien de passer par l'index de la feuille puisque J me donne déjà la position dans le tableau, par contre c'est à numfich qu'il faut ôter 1.
Donc modfier:

Then F.Name = ToR(F.Index) par Then F.Name = ToR(J)
et
TfiN(NumFich) & ".xls" par TfiN(NumFich-1) & ".xls"


Mais d'aprés ce que tu demandes je ne comprends plus la logique de 3 fichiers on passe à 4 F4 devient c ? ...

A+++