[VBA] Transfert vers plusieurs onglet
Oui je crains que tu ais raison.
le premier message me mets :
et quand j'appuis sur debogage
Donc laisse tomber je vais lui demander si il peut revoir son code VBA,
Bonjour, Steelson,
Merci pour ta macro, elle marche bienj'aurais une petite modification a te demandé (enfin 2)
- Au lieu de B mettre la colonne A en scanne
- Serai t’il possible de mettre les onglets en orange quand il une modification dans une feuille.
Par avance merci
Sub AJOUTER()
For Each f In Worksheets
With f.Tab
.ColorIndex = xlNone
.TintAndShade = 0
End With
Next
Set plage = Range("A" & Rows.Count).End(xlUp).CurrentRegion
nbcol = plage.Columns.Count - 1
For i = 1 To plage.Rows.Count
initiale = Left(plage.Cells(i, 1), 1)
With Sheets(initiale)
plage.Cells(i, 1).Resize(1, nbcol).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
With .Sort
.SetRange Sheets(initiale).Range("A1").CurrentRegion
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With .Tab
.Color = 49407
.TintAndShade = 0
End With
End With
Next
End SubBonjour Steelson,
C'est super merci beaucoup ca marche nickel
Bon Dimanche à toi
Sub AJOUTER() For Each f In Worksheets With f.Tab .ColorIndex = xlNone .TintAndShade = 0 End With Next Set plage = Range("A" & Rows.Count).End(xlUp).CurrentRegion nbcol = plage.Columns.Count - 1 For i = 1 To plage.Rows.Count initiale = Left(plage.Cells(i, 1), 1) With Sheets(initiale) plage.Cells(i, 1).Resize(1, nbcol).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) .Sort.SortFields.Clear .Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers With .Sort .SetRange Sheets(initiale).Range("A1").CurrentRegion .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With With .Tab .Color = 49407 .TintAndShade = 0 End With End With Next End Sub
Re, Pardon de t'embeter,
Il ne marche comme l'autre code, que tu m'as fait, là quand je rempli :
Dans "Nouveau Albums" - la ligne 1 - la colonne A B C D, quand je clique sur ajouter il me rajoute bien la colonne A B mais pas les autres
Tandis que l'autre il m'ajoutais toutes les colonnes rempli
Exact, il manque la dernière colonne.
Change cette ligne :
nbcol = plage.Columns.Count en enlevant le -1
Bonsoir Steelson,
J'ai voulu mettre un album qui commence par 0-9
4 the Cause
50 cent
et dans un autre dossier :
1996 - NRJ Dance Machine
Il quand j'ai fait ajouter il ma mis une erreur "With Sheets(initiale)" en jaune, tu crois que tu pourrais faire quelques chose.
Sinon tout le reste ca marche nickel
Merci
En effet, je n'avais pas fait attention ...
initiale = Left(plage.Cells(i, 1), 1)
If IsNumeric(initiale) Then initiale = "0-9"Merci beaucoup,
Une petite question est-ce que ton code marcherait sur fichier avec des feuilles années :
je m'explique :
je viens de me créer un autre fichier nommé "COMPILATIONS"
j'ai créer des feuilles par années et 3 feuilles avec des noms.
et je voudrais faire la même chose que les albums est-ce possible ?
si ça t’embêtes pas bien sur,
Merci en tout cas
Aucun soucis, dès lors que l'on peut déterminer le nom de l'onglet à partir de la cellule, quelle que soit la position de l'année dans la cellule (il suffira de tester une suite de 4 chiffres)
Mets un jeu d'essai dans Nouveaux Albums...
Il faudrait vérifier que
- l'onglet existe bien
- la cellule comporte bien une suite de 4 chiffres
Sub AJOUTER() For Each f In Worksheets With f.Tab .ColorIndex = xlNone .TintAndShade = 0 End With Next Set plage = Range("A" & Rows.Count).End(xlUp).CurrentRegion nbcol = plage.Columns.Count For i = 1 To plage.Rows.Count Set obj = CreateObject("vbscript.regexp") obj.Pattern = "[0-9]{4}" onglet = obj.Execute("ertyu2002rtyui")(0) With Sheets(onglet) plage.Cells(i, 1).Resize(1, nbcol).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) .Sort.SortFields.Clear .Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers With .Sort .SetRange Sheets(onglet).Range("A1").CurrentRegion .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With With .Tab .Color = 49407 .TintAndShade = 0 End With End With Next End Sub
Merci beaucoup,
Alors j'ai essayé ton code il marche bien sauf qu'il me met tout dans 2002, je pense que ca viens de cette ligne :
onglet = obj.Execute("ertyu2002rtyui")(0)je te remets mon fichier "COMPILATIONS" en pièces jointes avec dans "Nouveaux Albums" des exemples :
et du coup serait-il possible de faire comme cela :
- NRJ Superqstarts : l'ajouter des qu'il y a NRJ dans l'onglet "NRJ" tel quel.
- SKYROCK HITS 2020 : l'ajouter des qu'il y a SKYROCK dans l'onglet "SKYROCK" tel quel.
- FUN DANCE 2021 : l'ajouter des qu'il y a FUN dans l'onglet "FUN" tel quel.
- 2018 - les beaux artistes : l'ajouter des qu'il y a une année avec le tiret dans l'onglet "de l'année adéquat" et de le modifier "Les beaux artistes".
Sachant que pour ce dernier les années sont évolutive, la dans mon classeur je m'arrêter 2020 mais il y aura d'autres années.
Mais oui bien sûr, je suis désolé, c'était juste pour un essai ...
onglet = obj.Execute(cells(i,1).value)(0)mais cela devient compliqué de mettre parfois dans un onglet texte, parfois dans une année !
Bon je te refais cela rapidement (le temps de terminer un autre sujet entamé)
je te remercie d'avance, c'est pas d'une urgence absolue, je peux patienter
la ca me le mets dans la bonne année,
Bon courage à toi
Sub AJOUTER()
Dim dico As Object
Set dico = CreateObject("Scripting.Dictionary")
For Each f In Worksheets
If f.Name <> ActiveSheet.Name Then
dico(f.Name) = ""
With f.Tab
.ColorIndex = xlNone
.TintAndShade = 0
End With
End If
Next
Set plage = Range("A" & Rows.Count).End(xlUp).CurrentRegion
nbcol = plage.Columns.Count
For i = 1 To plage.Rows.Count
Set obj = CreateObject("vbscript.regexp")
obj.Pattern = "[0-9]{4}"
txt = plage.Cells(i, 1).Value
Set annee = obj.Execute(txt)
If annee.Count > 0 Then
onglet = CStr(annee(0))
If dico.exists(onglet) Then
With Sheets(onglet)
plage.Cells(i, 1).Resize(1, nbcol).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
With .Sort
.SetRange Sheets(onglet).Range("A1").CurrentRegion
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With .Tab
.Color = 49407
.TintAndShade = 0
End With
End With
End If
End If
onglet = Split(plage.Cells(i, 1).Value & " ", " ")(0)
If dico.exists(onglet) Then
With Sheets(onglet)
plage.Cells(i, 1).Resize(1, nbcol).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
With .Sort
.SetRange Sheets(onglet).Range("A1").CurrentRegion
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With .Tab
.Color = 49407
.TintAndShade = 0
End With
End With
End If
Next
End Sub- 2018 - les beaux artistes : l'ajouter des qu'il y a une année avec le tiret dans l'onglet "de l'année adéquat" et de le modifier "Les beaux artistes".
J'ai pas pigé la fin de la phrase !
quand je mets "2018 - les beaux artistes", quand il l'ajoutes dans l’onglet "2018", je voudrais qu'il m’enlève "xxxx - " et qu'il me laisse "²Les beaux artistes"
en plus clair je voudrais qu'il me laisse que le nom de l'album sans l'année et le tiret
Sub AJOUTER()
Dim dico As Object
Set dico = CreateObject("Scripting.Dictionary")
For Each f In Worksheets
If f.Name <> ActiveSheet.Name Then
dico(f.Name) = ""
With f.Tab
.ColorIndex = xlNone
.TintAndShade = 0
End With
End If
Next
Set plage = Range("A" & Rows.Count).End(xlUp).CurrentRegion
nbcol = plage.Columns.Count
For i = 1 To plage.Rows.Count
' cas d'un nom
onglet = Split(plage.Cells(i, 1).Value & " ", " ")(0)
If dico.exists(onglet) Then
With Sheets(onglet)
plage.Cells(i, 1).Resize(1, nbcol).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
With .Sort
.SetRange Sheets(onglet).Range("A1").CurrentRegion
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With .Tab
.Color = 49407
.TintAndShade = 0
End With
End With
End If
' cas d'une année
Set obj = CreateObject("vbscript.regexp")
obj.Pattern = "[0-9]{4}"
txt = plage.Cells(i, 1).Value
Set annee = obj.Execute(txt)
If annee.Count > 0 Then
onglet = CStr(annee(0))
If dico.exists(onglet) Then
With Sheets(onglet)
plage.Cells(i, 1).Resize(1, nbcol).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
With .Sort
.SetRange Sheets(onglet).Range("A1").CurrentRegion
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With .Tab
.Color = 49407
.TintAndShade = 0
End With
End With
plage.Cells(i, 1).Value = Replace(plage.Cells(i, 1).Value, annee(0) & " - ", "")
End If
End If
Next
End Subpour les années, il me mets 2 fois l'album
et c'est comme ça que vous qu'il soit si c'est possible :
