Fragmentation d'un fichier en plusieurs

Version imprimable

26/07/2010, 21h09
patcho

Fragmentation d'un fichier en plusieurs

Bonjour,

Débutant en macro, j'ai le problème suivant. J'ai 6 fichiers d'env. 100 onglets chacun. Chaque onglet/feuille représente la fiche d'un collaborateur. Je désire faire un fichier par feuille et que ce fichier s'enregistre et se renomme automatiquement avec le nom de la feuille par une macro.

De plus, un fichier index reprendra les informations des cellules a1 et a2 des 600 feuilles. Faisable et sûr???

Merci d'avance.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Public Sub enregistre()
 
Dim repertoire As String
repertoire = "C:\temp\"
 
Set F1 = ActiveWorkbook
For i = 1 To F1.Worksheets.Count
 
    F1.Activate
    nom = Worksheets(i).Name
    F1.Worksheets(i).Cells.Copy
    Workbooks.Add
    ActiveSheet.Paste
    ActiveSheet.Name = nom
    ActiveWorkbook.SaveAs Filename:=repertoire & nom & ".xls", _
        FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWorkbook.Close
Next i
 
End Sub

Copier la feuille au lieu de copier le contenu de la feuille

Code:

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
Option Explicit
Public Sub Scinde()
Dim awbk As Workbook, wbk As Workbook, arwbk As Workbook
Dim ws As Worksheet
Dim Repert As String, FichArch As String
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set awbk = ThisWorkbook
   Repert = awbk.Path & "\"
   FichArch = Repert & "Archives.xls"     'Créer un fichier dans le même dossier nommé Archives
   Set arwbk = Workbooks.Open(FichArch)
      For Each ws In awbk.Worksheets
         Set wbk = Workbooks.Add(1)
            ws.Copy before:=wbk.Sheets(1)
            wbk.Sheets(2).Delete
            wbk.SaveAs Repert & ws.Name & ".xls"
            wbk.Close
         Set wbk = Nothing
         With arwbk.Sheets(1)
            newlig = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            .Range("A" & newlig) = ws.Name
            .Range("B" & newlig & ":C" & newlig).Value = Application.Transpose(ws.Range("A1:A2").Value)
         End With
      Next ws
      arwbk.Save
      arwbk.Close
   Set arwbk = Nothing
Set awbk = Nothing
Application.DisplayAlerts = False
End Sub