Macro création automatique de feuilles
GRES35
Messages postés
2
Date d'inscription
mercredi 31 mai 2006
Statut
Membre
Dernière intervention
2 juin 2006
-
31 mai 2006 à 22:09
GRES35 Messages postés 2 Date d'inscription mercredi 31 mai 2006 Statut Membre Dernière intervention 2 juin 2006 - 2 juin 2006 à 22:34
GRES35 Messages postés 2 Date d'inscription mercredi 31 mai 2006 Statut Membre Dernière intervention 2 juin 2006 - 2 juin 2006 à 22:34
A voir également:
- Macro création automatique de feuilles
- Lancer une macro automatiquement tous les jours - Forum VBA Office (Excel, Word ...)
- Creation pdf jpg - Forum Visual Basic 6
- Mode création excel ✓ - Forum VBA Office (Excel, Word ...)
- Défilement automatique page web - Forum Javascript / DHTML
- Activer macro outlook - Forum Visual Basic
2 réponses
thonyk
Messages postés
8
Date d'inscription
mardi 28 mars 2006
Statut
Membre
Dernière intervention
1 juin 2006
1 juin 2006 à 10:58
1 juin 2006 à 10:58
je ne m'y connais pas beaucoup, mais ce que je te conseille, c'est de faire une macro qui trie tes décideurs par ordre alphabétique.
Columns("D:D").Select
Selection.Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
par contre, il faudrait effectivement que tu vires ta première ligne.
ensuite, tu fait:
dim pred as string, i as long
pred="": i=1
Do Until Cells(i, 4) = ""
If pred = Trim(Cells(i, 2)) Then
Rows(i & ":" & i).Select
'.....
'copie dans feuille de pred
Else
'copie dans nouvelle feuille (que tu peux nommer comme ton décideur)
'.......
i = i + 1
End If
Loop
'et là, je pense que tu devrais t'en sortir, moi je viens de faire pratiquement la meme chose pour trier des données avec doublons avant de les insérer dans une base.
'si tu veux plus d'explications, contact moi.
Columns("D:D").Select
Selection.Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
par contre, il faudrait effectivement que tu vires ta première ligne.
ensuite, tu fait:
dim pred as string, i as long
pred="": i=1
Do Until Cells(i, 4) = ""
If pred = Trim(Cells(i, 2)) Then
Rows(i & ":" & i).Select
'.....
'copie dans feuille de pred
Else
'copie dans nouvelle feuille (que tu peux nommer comme ton décideur)
'.......
i = i + 1
End If
Loop
'et là, je pense que tu devrais t'en sortir, moi je viens de faire pratiquement la meme chose pour trier des données avec doublons avant de les insérer dans une base.
'si tu veux plus d'explications, contact moi.
GRES35
Messages postés
2
Date d'inscription
mercredi 31 mai 2006
Statut
Membre
Dernière intervention
2 juin 2006
2 juin 2006 à 22:34
2 juin 2006 à 22:34
Merci pour ta réponse thonyk.
Finalement, j'ai réussi à trouver un code sur un site en anglais.En
adaptant à mon exemple, j'ai exactement ce que je voulais.
Avant d'utiliser la macro, il faut définir une base de données.
Insertion/Nom/définir.Nommer la base puis sélectionner l'ensemble des
cellules du tableau.
Si tu souhaites en parler, n'hésite pas.
Code :
Option Explicit (déclarations)
Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")
'extract a list of Sales Reps
ws1.Columns("C:C").Copy _
Destination:=Range("P1")
ws1.Columns("P:P").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("N1"), Unique:=True
r = Cells(Rows.Count, "N").End(xlUp).Row
'set up Criteria Area
Range("P1").Value = Range("C1").Value
For Each c In Range("N2:N" & r)
'add the rep name to the criteria area
ws1.Range("P2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("P1:P2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("P1:P2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("N:P").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
Finalement, j'ai réussi à trouver un code sur un site en anglais.En
adaptant à mon exemple, j'ai exactement ce que je voulais.
Avant d'utiliser la macro, il faut définir une base de données.
Insertion/Nom/définir.Nommer la base puis sélectionner l'ensemble des
cellules du tableau.
Si tu souhaites en parler, n'hésite pas.
Code :
Option Explicit (déclarations)
Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")
'extract a list of Sales Reps
ws1.Columns("C:C").Copy _
Destination:=Range("P1")
ws1.Columns("P:P").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("N1"), Unique:=True
r = Cells(Rows.Count, "N").End(xlUp).Row
'set up Criteria Area
Range("P1").Value = Range("C1").Value
For Each c In Range("N2:N" & r)
'add the rep name to the criteria area
ws1.Range("P2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("P1:P2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("P1:P2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("N:P").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function