Dispatcher
Bonjour, j'ai recuperer une macro pour dispatcher des lignes identiques sur une feuille et les regrouper par nom de la colonne a sur des feuilles nommé par le texte en a , au début cela fonctionnait ,et la ca bloque sur la 2 ligne de la macro,je ne suis pas un expert en la matière qq peut il m'aider
voici le code que j'utilise
Sub dispatch()
Columns("C:C").Select
ActiveWorkbook.Worksheets("DATA").AutoFilter.Sort.SortFields.Clear <-- 'c'est ici que ca bloque'
ActiveWorkbook.Worksheets("DATA").AutoFilter.Sort.SortFields.Add Key:= _
Range("C1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("DATA").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Dim CptLig As Integer
Dim Feuille As Worksheet
For CptLig = 3 To Feuil1.Range("A65536").End(xlUp).Row
Set Feuille = Nothing
If Not FeuilleExiste(Feuil1.Range("A" & CptLig).Value) Then
Set Feuille = Sheets.Add(After:=Worksheets(Worksheets.Count))
Feuille.Name = Feuil1.Range("A" & CptLig).Value
Feuil1.Rows("1:2").Copy Destination:=Feuille.Rows("1:2")
End If
If Feuille Is Nothing Then Set Feuille = Sheets(Feuil1.Range("A" & CptLig).Value)
Feuil1.Rows(CptLig).Copy Destination:=Feuille.Range("A" & Feuille.Range("A65536").End(xlUp).Row + 1)
Next CptLig
Feuil1.Activate
End Sub
Merci de votre aide
Bonjour et
Prends connaissance de https://forum.excel-pratique.com/viewtopic.php?f=2&t=13 et notamment du $6
Et utilise la balise </> pour rendre ton code lisible.
Pour ton sujet, tu peux aussi voir ici : https://www.excel-pratique.com/fr/telechargements/utilitaires/dispatcher-compiler-excel-no466
edit : Bonjour Bruno
Quel est l'intérêt d dispatcher par onglet ?
Re,
Moi en tout cas, j'y vois une grosse anomalie
Trier uniquement la colonne "C" ou est-ce que je me trompe
Pour l'aspect dispatch
Option Explicit
Option Base 1
Sub dispatcher()
Dim Tbl As Variant, data As Variant, i%
Dim dico1 As Object, cle1 As Variant, result1 As Variant, prov1 As String, sw As Worksheet
Dim critere%
'###### à ajutser #######
critere = 1 ' num colonne
Application.DisplayAlerts = False
For Each sw In Worksheets
If sw.Name <> "data" Then sw.Delete
Next
Application.DisplayAlerts = True
data = ActiveSheet.Range("A3:K" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row)
Set dico1 = CreateObject("Scripting.Dictionary")
For i = LBound(data) + 1 To UBound(data) ' hors en-tête
dico1(data(i, critere)) = ""
Next
prov1 = data(1, critere)
For Each cle1 In dico1.Keys
Sheets.Add(After:=Sheets(Sheets.Count)).Name = cle1
data(1, critere) = cle1 ' pour emmener aussi l'en-tête dans le filtre
result1 = filtreArray(data, critere, cle1)
Cells(3, 1).Resize(UBound(result1, 1), UBound(result1, 2)) = result1
Cells(3, 1).Offset(0, critere - 1) = prov1
Next
Sheets("data").Select
MsgBox "Terminé !"
End Sub
Function filtreArray(Tbl, col, param)
Dim i%, j%, k%, n%
For i = 1 To UBound(Tbl)
If Tbl(i, col) = param Then n = n + 1
Next i
Dim temp: ReDim temp(1 To n, 1 To UBound(Tbl, 2))
j = 0
For i = 1 To UBound(Tbl)
If Tbl(i, col) = param Then
j = j + 1
For k = 1 To UBound(Tbl, 2)
temp(j, k) = Tbl(i, k)
Next k
End If
Next i
filtreArray = temp
End Function
Il reste à recopier les lignes d'en-tête et les autres fonctions ...
Re,
Steelson tu es un "salaud"
Je pense que globalhygiene va avoir directe un mal au crâne avec ton code
Re,
Steelson tu es un "salaud"
Je pense que globalhygiene va avoir directe un mal au crâne avec ton code
ok, j'aurais dû repartir de son code ... bon je vais voir cela ! mais comme tu disais, cela commençait mal !
edit : le problème est que je ne trouve pas dans son code l'instruction pour éclater le fichier en plusieurs onglets !
Re,
Non non, pas forcément repartir de son code, mais éviter tout ce qui est tableau (certes beaucoup plus rapide)
Le travail dans les tableaux sont vraiment à faire entre "pros"
Ben oui, mais voilà ce que je faisais en 2013, j'ai honte !Non non, pas forcément repartir de son code, mais éviter tout ce qui est tableau (certes beaucoup plus rapide)
Le travail dans les tableaux sont vraiment à faire entre "pros"
Option Explicit
Sub fragmenter()
Dim ws As Worksheet, wd As Worksheet
Dim critere As String
critere = Range("critere").Value
If critere = "" Then
Range("critere").Select
MsgBox "Merci de renseigner la colonne (en lettre) sur laquelle va s'appuyer le découpage du fichier !"
Exit Sub
End If
Sheets("data").Select
Set wd = ActiveSheet
' détection de la dernière colonne
Dim der_colonne As String
Dim der_num_colonne As Integer
der_num_colonne = [A1].End(xlToRight).Column
der_colonne = lettre_col(der_num_colonne)
' détection de la dernière ligne
Dim der_ligne As Long
der_ligne = [A1].End(xlDown).Row
' tri pour fragmentation des états sur ce critère
With wd.Sort
.SortFields.Clear
.SortFields.Add Key:=Range(critere & "2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A2:" & der_colonne & der_ligne)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' debut du traitement
Dim ligne_courante As Long, debut As Long, fin As Long, ligneVers As Long
Dim critere_courant
ligne_courante = 2
Do While ligne_courante <= der_ligne
critere_courant = Range(critere & ligne_courante).Value
debut = LigneDebut(critere_courant, Range(critere & "1").Column)
fin = LigneFin(critere_courant, Range(critere & "1").Column)
' creation de l'onglet
If Not FeuilleExiste(ThisWorkbook, "_" & critere_courant) Then
Sheets.Add
ActiveSheet.Name = "_" & critere_courant
Set ws = ActiveSheet
Else
Sheets("_" & critere_courant).Select
Cells.Clear
Set ws = ActiveSheet
End If
wd.Select
' recopie des en-têtes
' copie des en-têtes
wd.Rows("1:1").Select
Selection.Copy
ws.Paste
Application.CutCopyMode = False
ligneVers = 2
' recopie du contenu
wd.Rows(debut & ":" & fin).Select
Selection.Copy
ws.Select
ws.Cells(ligneVers, 1).Select
ws.Paste
Application.CutCopyMode = False
ws.Cells.Select
ws.Cells.EntireColumn.AutoFit
wd.Select
ligne_courante = LigneFin(critere_courant, Range(critere & "1").Column) + 1
Loop
MsgBox "Fragmentation terminée !"
End Sub
Function lettre_col(n As Integer)
lettre_col = Split(Cells(1, n).Address, "$")(1)
End Function
Function LigneDebut(recherche, colonne As Integer) As Long
LigneDebut = Application.Match(recherche, Columns(colonne), 0)
End Function
Function LigneFin(recherche, colonne As Integer) As Long
LigneFin = Application.Match(recherche, Columns(colonne), 1)
End Function
Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean
On Error Resume Next
FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing)
End Function
Re,
Ben oui, mais voilà ce que je faisais en 2013, j'ai honte !
Il ne faut surtout pas, bien au contraire
Perso, j'ai 2 façon de faire :
1) pour le forum avec un code le plus simple possible et des annotations pour que tout le monde comprenne
2) pour mes applis ou là, je ne m'occupe pas de la compréhension, mais de l'optimisation de de la rapidité de mon code
Sur le forum, je préfère franchement me mettre à la portée de tous, plutôt que de sortir ma "science"
Au plaisir
Tu as raison (j'étais du reste reparti d'une de mes applications)
Donc voici plus simple :
Option Explicit
Sub Dispatcher()
Dim i%, der%, cle As Variant, sw As Worksheet, dico As Object, tbl As Variant
Set sw = ActiveSheet
' j'affiche tout
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
' je cherche toutes les valeurs différentes colonne A via dico
der = Range("A" & Rows.Count).End(xlUp).Row
Set dico = CreateObject("Scripting.Dictionary")
For i = 4 To der
dico(Range("A" & i).Value) = ""
Next
' pour chaque valeur dans dico
For Each cle In dico.Keys
' j filtre
ActiveSheet.Range("$A$3:$K$" & der).AutoFilter Field:=1, Criteria1:=cle
' je copie
ActiveSheet.Range("$A$3:$K$" & der).Copy
' j'ajoute une feuille
Sheets.Add After:=ActiveSheet
' je sélectionne l'endroit où copier
Range("A3").Select
With ActiveSheet
' je colle et donne le nom du critère à la feuille
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Name = cle
End With
' je retourne sur la feuille principale
sw.Select
Next
ActiveSheet.ShowAllData
End Sub
J'ai été un peu vite, il faudrait supprimer les feuilles sauf data
Merci beaucoup, je viens de recopier ce code a la place de l'ancien et ça marche très bien ,encore merci ,je n'ai pas compris pourquoi ça ne marchais pas avant mais ce n'est pas très grave
très bon weekend a vous
et encore merci
Non mais si tu comprends le nouveau code (le dernier) c'est bien !Merci beaucoup, je viens de recopier ce code a la place de l'ancien et ça marche très bien ,encore merci ,je n'ai pas compris pourquoi ça ne marchais pas avant mais ce n'est pas très grave