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,

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

bonjour ci joint le fichier en question

cordialement

17data.xlsm (118.65 Ko)

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 ...

8data.xlsm (104.67 Ko)

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"

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 !
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
19data-1.xlsm (109.02 Ko)

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

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

Non mais si tu comprends le nouveau code (le dernier) c'est bien !
Rechercher des sujets similaires à "dispatcher"