Scinder un fichier en plusieurs onglets
Bon matin à tous,
Grâce au forum, j'ai trouvé une formule VBA qui fonctionne à merveille pour scinder mon fichiers en plusieurs onglets selon un critères bien précis.
J'aimerais pouvoir ajouter, à chaque onglets nouvellement créés, les trois premières lignes de l'onglets de départ : "Feuil1"
ainsi qu'un sous total (colonnes L à AB) à la dernière ligne de chaque onglet nouvellement créés.
Quelqu'un peut-il m'aider à placer la bonne commande au bon endroit,
Voici la formule que j'ai déniché sur le Forum(désolé je ne me souviens plus de qui elle était).
Sub creation_onglets()
Dim Ws As Worksheet
Dim trouve As Boolean
Dim contenu As String
Dim lig, derlig As Integer
With Sheets("Feuil1")
'à adapter Feuil1 = feuille ou sont vos données
derlig = .Range("A65536").End(xlUp).Row 'à adapter, E = colonne "Dossier groupe"
For lig = 2 To derlig
contenu = .Cells(lig, 1).Value
'à adapter 1 = 5ème col cf A ci dessus
For Each Ws In ThisWorkbook.Worksheets
trouve = False
If StrComp(Ws.Name, contenu, vbTextCompare) = 0 Then
trouve = True
Exit For
End If
Next Ws
If trouve = True Then
.Rows(lig).Copy Sheets(contenu).Range("A65536").End(xlUp).Offset(1, 0)
Else
Sheets.Add
ActiveSheet.Name = contenu
.Rows(lig).Copy Sheets(contenu).Range("A65536").End(xlUp).Offset(1, 0)
End If
Next lig
End With
End Sub
Bonsoir,
J'ai entièrement refait ton code, et rajouté les sommes voulues en fin de chaque onglet.
Tu cliques sur le dessin de la cellule E1 de l'onglet "base", et au bout de 2 secondes, tu as tous tes onglets de créés....
Tu noteras bien qu'il n'y a que 2 onglets, "base" et "modele", et ces 2 onglets sont impératifs
Le code :
Sub scinder()
Dim Cel As Range, Plg As Range
Dim DerLig As Long
Dim Numeros As Object
Dim Sh As Worksheet, FBase As Worksheet, FModele As Worksheet
Dim It As Variant
Set FBase = Sheets("base")
Set FModele = Sheets("modele")
Set Numeros = CreateObject("Scripting.Dictionary")
t = Timer
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
For Each Sh In Sheets
If Sh.Name <> FBase.Name And Sh.Name <> FModele.Name Then
Sh.Delete
End If
Next Sh
With FBase
DerLig = .Cells(Rows.Count, 1).End(xlUp).Row
Set Plg = .Range("A3:AB" & DerLig)
For Each Cel In .Range("A4:A" & DerLig)
If Cel.Value <> "" Then
Cel.Value = Format(Trim(Cel.Value), "0000")
Numeros(Cel.Value) = Cel.Value
End If
Next Cel
End With
For Each It In Numeros.Items
FModele.Copy After:=Sheets(Sheets.Count)
With ActiveSheet
.Name = It
FBase.Range("BA4").FormulaR1C1 = "=RC1=" & It
Plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=FBase.Range("BA3:BA4"), _
CopyToRange:=.Range("A3:AB3"), Unique:=False
DerLig = .Cells(Rows.Count, 1).End(xlUp).Row + 1
With .Cells(DerLig, "L")
.FormulaR1C1 = "=SUM(R4C:R[-1]C)"
.AutoFill Destination:=.Resize(1, 17)
End With
End With
Next It
FBase.Range("BA4").ClearContents
FBase.Select
MsgBox Timer - t
End Sub
Le fichier :
Bon courage
Wow!
Merci cousinhub
Je viens d'arriver au bureau, je vais tester aujourd'hui après les rencontres de la journée et les autres rapports à fournir. J'ai même le goût de "caller" malade pour tester le tout tranquille.
Comme je suis un néophyte VBA j'ai pas vraiment compris toute la formule mais un gros merci, je suis sûr que c'est parfait.
à plus tard.
Bon matin Cousinhub,
Effectivement, c'est parfait!! Merci.
Tu viens de nous sauver des heures de Copier-Coller.
Je vais même l'adapter pour un autre rapport du même genre.
Peut-être aurais-je des questions sur le pourquoi de certaines composantes de la formule.
Bon week-end
SPAGE
Bonjour à tous
BOnjour Cousinhub,
Je ne sais pas si tu te souviens, mais tu m'as "fabriqué" une macro pour scinder un fichier excel en plusieurs onglets. C'est vraiment d'une efficacité extra.
J'ai réussi à adapter cette dernière à de nouveaux rapports, sauf le dernier,
Je dois faire un onglet à chaque changement de valeurs de la colonne "C"
Les onglets se nomment de la bonne façon mais les données ne suivent pas.
Quelqu'un pourrait-il m'aider avec ce petit problème.
J'ai trouvé une solution boiteuse : je copie les données de la colonne "C" dans la colonne "A" et le tour est joué mais est-ce possible de ne pas "Copier-coller" et de faire suivre les données de la colonne C dans les onglets.
Cordialement
Spage
Bonsoir,
Dans le code, il faut que tu modifies la formule que je mets dans la cellule CA4...(qui me sert pour le filtre élaboré)
Pour le moment, tu as cette ligne :
......
......
FBase.Range("CA4").FormulaR1C1 = "=RC1=" & It
......
......
Il faut que remplaces par ceci :
......
......
FBase.Range("CA4").FormulaR1C1 = "=RC3=" & It
......
......
Bonne soirée
Bonsoir,
C'est encore exact et parfait!!
Ma question de débutant: Est-ce que le 3 de ''RC3'' correspond à la troisième colonne. Si oui, c'est-à-dire que si j'inscris ''RC4'', la macro filtrera sur la 4e colonne?????
Merci encore.
Cordialement
Spage
Bonjour à tous,
J'essai seulement de changer la formule SUM pour un sous total
Je pensais la formule OK mais elle est toujours en erreur.
Le haut de la formule est dans les messages précédents.
Merci.
de votre aide
For Each It In Numeros.Items
FModele.Copy After:=Sheets(Sheets.Count)
With ActiveSheet
.Name = It
FBase.Range("CA4").FormulaR1C1 = "=RC3=" & It
Plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=FBase.Range("CA3:CA4"), _
CopyToRange:=.Range("A3:BM3"), Unique:=False
DerLig = .Cells(Rows.Count, 1).End(xlUp).Row + 2
With .Cells(DerLig, "O")
.FormulaR1C1 = "=SUBTOTAL(9;R[4]C:R[-1]C)"
.AutoFill Destination:=.Resize(1, 46)
End With
End With
Next It
FBase.Range("CA4").ClearContents
FBase.Select
MsgBox Timer - t
End Sub
J'ai trouvé grâce à NAD
Il faut mettre une (9,RC:RC) au lieu de (9;RC:RC)
BOnne journée