Dispatcher

Y compris Power BI, Power Query et toute autre question en lien avec Excel
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 15'011
Appréciations reçues : 889
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 10 avril 2020, 11:19

BrunoM45 a écrit :
10 avril 2020, 11:15
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

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Avatar du membre
BrunoM45
Modérateur
Modérateur
Messages : 3'450
Appréciations reçues : 142
Inscrit le : 29 octobre 2011
Version d'Excel : 2016 FR, O365 FR
Contact :

Message par BrunoM45 » 10 avril 2020, 12:04

Re,
Steelson a écrit :
10 avril 2020, 11:19
Ben oui, mais voilà ce que je faisais en 2013, j'ai honte !
Il ne faut surtout pas, bien au contraire 8-) :sp:

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" :wink:

Au plaisir :O-O:
Modifié en dernier par BrunoM45 le 10 avril 2020, 16:17, modifié 1 fois.
1 membre du forum aime ce message.
[F1] est une touche qui appelle l'aide : Essayez, c'est assez performant et on trouve plein de choses

Il n'y a ni bon ni mauvais usage de la liberté d'expression, il n'en existe qu'un usage insuffisant.
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 15'011
Appréciations reçues : 889
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 10 avril 2020, 12:57

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

DATA (1).xlsm
(109.02 Kio) Pas encore téléchargé
J'ai été un peu vite, il faudrait supprimer les feuilles sauf data

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
g
globalhygiene
Jeune membre
Jeune membre
Messages : 12
Inscrit le : 10 avril 2020
Version d'Excel : 2010 FR

Message par globalhygiene » 10 avril 2020, 14:11

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
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 15'011
Appréciations reçues : 889
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 10 avril 2020, 14:16

globalhygiene a écrit :
10 avril 2020, 14:11
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 ! :btres:

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Répondre
  • Sujets similaires
    Réponses
    Vues
    Dernier message