séparer un fichier en plusieurs onglets

y a t'il un moyen d'automatiser l'éclatement en onglet ?

y a t'il un moyen d'automatiser l'éclatement en onglet ?

Tu as essayé à l'aide de filtre(s) ?
PS : A proscrire : les boucles

AV

bonjour,

je gère le suivi de bagde de ma société par service.
j'ai donc un tableau de suivi que je mets à jours tous les mois. ce tableau
comporte toutes les personnes ayant un badge et le service auquel elle
appartient.
je dois ensuite éclater ce fichier en autant d'onglet qu'il y a de service.

le problème et qu'il s'agit d'un gros fichier, il doit y avoir environ 1000
personnes pour 100 service. cela demande un temps fou et s'est très pénible à
faire.

y a t'il un moyen d'automatiser l'éclatement en onglet ?

merci de vos réponses ou de vos idées.

Bonjour,

Une piste en VBA qui devrait aller dans votre sens.
Copiez le code ci-desssous dans un module standard
et lancer la macro "EclaterOnglets" en ayant préalablement pris soin
d'intituler la colonne des services par SERVICE.
(vous pouvez également changer la valeur de la constante
Const SERVICE As String = "SERVICE" par exemple par
Const SERVICE As String = "TOTO")
'****************
Option Explicit
Const SERVICE As String = "SERVICE"

Sub EclaterOnglets()
Dim A$
Dim var
Dim W As Workbook
Dim S As Worksheet
Dim Cle
Dim R As Range
Dim i&
Dim j&
Dim deb&
Dim fin&
Dim TR()
Dim Titres
var = ActiveSheet.UsedRange
For j& = 1 To UBound(var, 2)
If var(1, j&) = SERVICE Then
Cle = j&
Exit For
End If
Next j&
If Cle = 0 Then
MsgBox "Titre de colonne " & _
SERVICE & " introuvable."
Exit Sub
End If
A$ = ActiveSheet.Name
Cells.Copy
Set W = Workbooks.Add(xlWorksheet)
Set S = W.ActiveSheet
S.Paste
Application.CutCopyMode = False
S.Name = A$
Set R = S.UsedRange
R.Sort Key1:=Range(Cells(2, Cle), _
Cells(2, Cle)), _
Order1:=xlAscending, _
Header:=xlYes
var = R
Titres = R.Range(Cells(1, 1), _
Cells(1, UBound(var, 2)))
j& = 0
fin& = UBound(var, 1)
For i& = UBound(var, 1) To 2 Step -1
If var(i&, Cle) <> var(i& - 1, Cle) Then
deb& = i&
j& = j& + 1
ReDim Preserve TR(1 To j&)
TR(j&) = R.Range(Cells(deb&, 1), _
Cells(fin&, UBound(var, 2)))
fin& = i& - 1
End If
Next i&
On Error GoTo Erreur
Application.ScreenUpdating = False
For i& = UBound(TR) To 1 Step -1
Set S = W.Sheets.Add _
(after:=W.Sheets(W.Sheets.Count))
S.Range(Cells(1, 1), _
Cells(1, UBound(var, 2))) = Titres
S.Range(Cells(2, 1), _
Cells(UBound(TR(i&)) + 1, UBound(var, 2))) = TR(i&)
S.Name = TR(i&)(1, Cle)
Next i&
Erreur:
W.Sheets(1).Select
Application.ScreenUpdating = True
End Sub
'****************

Cordialement.
--
PMO
Patrick Morange

bonjour,

je gère le suivi de bagde de ma société par service.
j'ai donc un tableau de suivi que je mets à jours tous les mois. ce tableau
comporte toutes les personnes ayant un badge et le service auquel elle
appartient.
je dois ensuite éclater ce fichier en autant d'onglet qu'il y a de service.

le problème et qu'il s'agit d'un gros fichier, il doit y avoir environ 1000
personnes pour 100 service. cela demande un temps fou et s'est très pénible à
faire.

y a t'il un moyen d'automatiser l'éclatement en onglet ?

merci de vos réponses ou de vos idées.

Bonjour,

Une piste en VBA qui devrait aller dans votre sens.
Copiez le code ci-desssous dans un module standard
et lancer la macro "EclaterOnglets" en ayant préalablement pris soin
d'intituler la colonne des services par SERVICE.
(vous pouvez également changer la valeur de la constante
Const SERVICE As String = "SERVICE" par exemple par
Const SERVICE As String = "TOTO")
'****************
Option Explicit
Const SERVICE As String = "SERVICE"

Sub EclaterOnglets()
Dim A$
Dim var
Dim W As Workbook
Dim S As Worksheet
Dim Cle
Dim R As Range
Dim i&
Dim j&
Dim deb&
Dim fin&
Dim TR()
Dim Titres
var = ActiveSheet.UsedRange
For j& = 1 To UBound(var, 2)
If var(1, j&) = SERVICE Then
Cle = j&
Exit For
End If
Next j&
If Cle = 0 Then
MsgBox "Titre de colonne " & _
SERVICE & " introuvable."
Exit Sub
End If
A$ = ActiveSheet.Name
Cells.Copy
Set W = Workbooks.Add(xlWorksheet)
Set S = W.ActiveSheet
S.Paste
Application.CutCopyMode = False
S.Name = A$
Set R = S.UsedRange
R.Sort Key1:=Range(Cells(2, Cle), _
Cells(2, Cle)), _
Order1:=xlAscending, _
Header:=xlYes
var = R
Titres = R.Range(Cells(1, 1), _
Cells(1, UBound(var, 2)))
j& = 0
fin& = UBound(var, 1)
For i& = UBound(var, 1) To 2 Step -1
If var(i&, Cle) <> var(i& - 1, Cle) Then
deb& = i&
j& = j& + 1
ReDim Preserve TR(1 To j&)
TR(j&) = R.Range(Cells(deb&, 1), _
Cells(fin&, UBound(var, 2)))
fin& = i& - 1
End If
Next i&
On Error GoTo Erreur
Application.ScreenUpdating = False
For i& = UBound(TR) To 1 Step -1
Set S = W.Sheets.Add _
(after:=W.Sheets(W.Sheets.Count))
S.Range(Cells(1, 1), _
Cells(1, UBound(var, 2))) = Titres
S.Range(Cells(2, 1), _
Cells(UBound(TR(i&)) + 1, UBound(var, 2))) = TR(i&)
S.Name = TR(i&)(1, Cle)
Next i&
Erreur:
W.Sheets(1).Select
Application.ScreenUpdating = True
End Sub
'****************

Cordialement.
--
PMO
Patrick Morange

bonjour,

je gère le suivi de bagde de ma société par service.
j'ai donc un tableau de suivi que je mets à jours tous les mois. ce tableau
comporte toutes les personnes ayant un badge et le service auquel elle
appartient.
je dois ensuite éclater ce fichier en autant d'onglet qu'il y a de service.

le problème et qu'il s'agit d'un gros fichier, il doit y avoir environ 1000
personnes pour 100 service. cela demande un temps fou et s'est très pénible à
faire.

y a t'il un moyen d'automatiser l'éclatement en onglet ?

merci de vos réponses ou de vos idées.

je ne sais pas si mon explication était bien claire, il faudrait que la mise
en forme du tableau ainsi que la mise en page soit reprise sur tous les
onglets créés.
cela dit, je suis très impressionné...

Bonjour,

Ci-dessous le code modifié pour aller dans le sens
de votre demande.

'********************
Option Explicit
Const SERVICE As String = "SERVICE"

Sub EclaterOnglets_PMO()
Dim var
Dim Origine As Worksheet
Dim W As Workbook
Dim S As Worksheet
Dim Source As Worksheet
Dim Cle&
Dim R As Range
Dim i&
Dim j&
Dim deb&
Dim fin&
Dim TR()
Dim Titres
Dim nbLig&
Set R = ActiveSheet.UsedRange
If R.Row > 1 Or R.Column > 1 Then
MsgBox "La plage doit débuter en ligne 1 colonne A."
Exit Sub
End If
nbLig& = R.Rows.Count
var = R
For j& = 1 To UBound(var, 2)
If var(1, j&) = SERVICE Then
Cle& = j&
Exit For
End If
Next j&
If Cle& = 0 Then
MsgBox "Titre de colonne " & _
SERVICE & " introuvable."
Exit Sub
End If
Set Origine = ActiveSheet
Set W = Workbooks.Add(xlWorksheet)
Origine.Copy after:=W.Sheets(1)
Application.DisplayAlerts = False
W.Sheets(1).Delete
Set S = W.ActiveSheet
Application.DisplayAlerts = True
Set R = S.UsedRange
R.Sort Key1:=Range(Cells(2, Cle&), _
Cells(2, Cle&)), _
Order1:=xlAscending, _
Header:=xlYes
var = R
Titres = R.Range(Cells(1, 1), _
Cells(1, UBound(var, 2)))
j& = 0
fin& = UBound(var, 1)
For i& = UBound(var, 1) To 2 Step -1
If var(i&, Cle&) <> var(i& - 1, Cle&) Then
deb& = i&
j& = j& + 1
ReDim Preserve TR(1 To j&)
TR(j&) = R.Range(Cells(deb&, 1), _
Cells(fin&, UBound(var, 2)))
fin& = i& - 1
End If
Next i&
On Error GoTo Erreur
Set Source = W.ActiveSheet
Application.ScreenUpdating = False
For i& = 1 To UBound(TR)
Source.Copy after:=W.Sheets(1)
Set S = W.ActiveSheet
S.Cells.ClearContents
S.Range(Cells(1, 1), _
Cells(1, UBound(var, 2))) = Titres
S.Range(Cells(2, 1), _
Cells(UBound(TR(i&)) + 1, _
UBound(var, 2))) = TR(i&)
S.Rows("" & UBound(TR(i&)) + 2 & _
":" & nbLig& & "").Delete
S.Name = TR(i&)(1, Cle&)
S.[a1].Select
Next i&
Erreur:
W.Sheets(1).Select
[a1].Select
Application.ScreenUpdating = True
End Sub
'********************

Cordialement.
--
PMO
Patrick Morange

je ne sais pas si mon explication était bien claire, il faudrait que la mise
en forme du tableau ainsi que la mise en page soit reprise sur tous les
onglets créés.
cela dit, je suis très impressionné...

Bonjour,
Ci-dessous le code modifié pour aller dans le sens
de votre demande.
'********************
Option Explicit
Const SERVICE As String = "SERVICE"
Sub EclaterOnglets_PMO()
Dim var
Dim Origine As Worksheet
Dim W As Workbook
Dim S As Worksheet
Dim Source As Worksheet
Dim Cle&
Dim R As Range
Dim i&
Dim j&
Dim deb&
Dim fin&
Dim TR()
Dim Titres
Dim nbLig&
Set R = ActiveSheet.UsedRange
If R.Row > 1 Or R.Column > 1 Then
MsgBox "La plage doit débuter en ligne 1 colonne A."
Exit Sub
End If
nbLig& = R.Rows.Count
var = R
For j& = 1 To UBound(var, 2)
If var(1, j&) = SERVICE Then
Cle& = j&
Exit For
End If
Next j&
If Cle& = 0 Then
MsgBox "Titre de colonne " & _
SERVICE & " introuvable."
Exit Sub
End If
Set Origine = ActiveSheet
Set W = Workbooks.Add(xlWorksheet)
Origine.Copy after:=W.Sheets(1)
Application.DisplayAlerts = False
W.Sheets(1).Delete
Set S = W.ActiveSheet
Application.DisplayAlerts = True
Set R = S.UsedRange
R.Sort Key1:=Range(Cells(2, Cle&), _
Cells(2, Cle&)), _
Order1:=xlAscending, _
Header:=xlYes
var = R
Titres = R.Range(Cells(1, 1), _
Cells(1, UBound(var, 2)))
j& = 0
fin& = UBound(var, 1)
For i& = UBound(var, 1) To 2 Step -1
If var(i&, Cle&) <> var(i& - 1, Cle&) Then
deb& = i&
j& = j& + 1
ReDim Preserve TR(1 To j&)
TR(j&) = R.Range(Cells(deb&, 1), _
Cells(fin&, UBound(var, 2)))
fin& = i& - 1
End If
Next i&
On Error GoTo Erreur
Set Source = W.ActiveSheet
Application.ScreenUpdating = False
For i& = 1 To UBound(TR)
Source.Copy after:=W.Sheets(1)
Set S = W.ActiveSheet
S.Cells.ClearContents
S.Range(Cells(1, 1), _
Cells(1, UBound(var, 2))) = Titres
S.Range(Cells(2, 1), _
Cells(UBound(TR(i&)) + 1, _
UBound(var, 2))) = TR(i&)
S.Rows("" & UBound(TR(i&)) + 2 & _
":" & nbLig& & "").Delete
S.Name = TR(i&)(1, Cle&)
S.[a1].Select
Next i&
Erreur:
W.Sheets(1).Select
[a1].Select
Application.ScreenUpdating = True
End Sub
'********************
Cordialement.
--
PMO
Patrick Morange

je ne sais pas si mon explication était bien claire, il faudrait que la
mise
en forme du tableau ainsi que la mise en page soit reprise sur tous les
onglets créés.
cela dit, je suis très impressionné...