Transférer des lignes en fonction du mois (macro)

Le 03/06/2019 à 11:35

bonjour le forum

je reçois un fichier avec des centaines de lignes

je voudrais les rassembler dans des onglets en fonction du mois ( de janvier à décembre )par macro

merci pour l'aide

tomatito37

143-6-2019-exel-pratique-transferer-des-lignes-en-fonction-du-mois.xlsx (11.92 Ko)
Le 03/06/2019 à 15:20

Bonjour

Voici un code qui devrait fonctionner :

'   Declarations des onglets
Public wsBase      As Object    '   celui de la base de donnees
Public wsMois      As Object    '   onglet "valise" pour l'ensemble des mois

Sub DecoupeMois()
Dim moisActuel          '   mois de la ligne en cours

Dim tabBase()           '   Tableau des donnees
Dim cptLig, cptCol      '   compteur de lignes/colonnes
Dim ligDeb, colDeb      '   ligne/colonne de debut
Dim ligFin, colFin      '   -- de fin

Dim colDate             '   colonne de la date de reference

    '   Initialisation de l'onglet "base de donnees"
    Set wsBase = Worksheets("données ")     '   ATTENTION l'espace est obligatoire parce le nom est ecrit comme a dans la PJ)

    '   La combinaison SET +WITH/END WITH permet de ne pas deplacer physiquement le pointeur de cellule
    '   donc plus de rapidite !!

    '   Avec cet onglet [données ]
    With wsBase
        ligDeb = 2      '   ligne de debut des donnees
        colDeb = 1      '   colonne --

        '   Recherche de la derniere ligne de donnees
        ligFin = .Cells(Rows.Count, colDeb).End(xlUp).Row
        ligFin = IIf(ligFin >= ligDeb, ligFin, 0)
        '   Recherche de la derniere colonne du tableau des donnees
        colFin = .Cells(1, Columns.Count).End(xlToLeft).Column

        colDate = 3     '   colonne de la date de reference (supposee la 3eme - a adpter au besoin)

        '   Si il y a des donnees
        If (ligFin > 0) Then
            '   Charger ces donnees dans le tableau des donnees
            '   =>  utilisation du tableau = gain de rapidite puisque les donnees ne sont lues qu'une seule et unique fois
            '       pas d'aller et retour dans les onglets pour les copier/coller
            tabBase = Range(.Cells(ligDeb, colDeb), .Cells(ligFin, colFin))
            '   Pour chaque ligne de donnees
            For cptLig = 1 To UBound(tabBase, 1)
                '   Recuperer le n° de mois et mettre au format MM - 2 caracteres couples a zero 01..12 => A adapter selon le besoin
                moisActuel = Format(Month(tabBase(cptLig, colDate)), "00")
                '   Verifier si l'onglet de ce mois existe
                If ExisteMois(moisActuel, colFin) Then
                    Set wsMois = Worksheets(moisActuel) '   Initialiser l'onglet de ce mois
                    '   Avec l'onglet de ce mois
                    With wsMois
                        '   Rechercher la derniere ligne
                        ligFin = .Cells(Rows.Count, colDeb).End(xlUp).Row
                        '   Pour chaque colonne de la base de donnees
                        For cptCol = 1 To colFin
                            .Cells(ligFin + 1, cptCol) = tabBase(cptLig, cptCol)    '   sur la derniere ligne +1 copier les donnees du tableau
                        Next        '   colonne suivante (ou fin)
                    End With    '   Fin du travail avec ce mois
                    Set wsMois = Nothing    '   Liberer l'onglet => !!! ne jamais oublier cette ligne lors de l'utilisation d'un SET !!!
                End If  '   Fin du test du mois
            Next    '   Ligne suivante de la base de donnees (ou fin)
        '   Sinon (si la ligne de fin = 0 c'est qu'il n'y a pas de donnees)
        Else
            MsgBox "Aucune données à traiter !", vbInformation + vbOKOnly, "Pour information !"
        End If  '   Fin du test des lignes a traiter
    End With    '   Fin de travail avec l'onglet [données ]

    Set wsBase = Nothing    '   Liberer l'onglet => !!! ne jamais oublier cette ligne lors de l'utilisation d'un SET !!!

End Sub

'   Recherche si l'onglet du "quelMois" existe
Function ExisteMois(quelMois, colFin) As Boolean
Dim cellTest        '   cellule bidon pour tester l'onglet
Dim nouvMois        '   nom du mois au cas où il faudrait le creer

    On Error GoTo errMois
    '   la cellule bidon va retourner soit
    '   -   la valeur de la 1ere cellule
    '   -   une ERREUR  =>  cela indique que l'onglet n'existe pas !
    '   le branchement On Error Goto est donc effectué
    cellTest = Worksheets(quelMois).Cells(1, 1)
    On Error GoTo 0     '   Fin du traitement des erreurs => !!! ne jamais oublier ce "fin de traitement" sinon plus aucune erreur ne sera correctement gérée !!!

    '   Dans tous les cas (maintenant) l'onglet de ce mois existe
    ExisteMois = True

    Exit Function   '   Fin (anticipée) de la fonction pour ne refaire le traitement des erreurs

errMois:    '   Gestion du cas où l'onglet de ce mois n'existe pas
        '   Ajouter l'onglet (en dernier)
        Sheets.Add After:=Sheets(ActiveWorkbook.Sheets.Count)
        With Sheets(Sheets.Count)
            .Name = quelMois    '   Nommer cet onglet du nom du mois
            '   Copier la ligne d'entete
            wsBase.Range(wsBase.Cells(1, 1), wsBase.Cells(1, colFin)).Copy .Cells(1, 1)
        End With

        Resume Next '   pour revenir a la suite "normale" du traitement (juste après la ligne qui a provoquée l'erreur)

End Function
Le 03/06/2019 à 16:18

le forum

Gli73

merci pour ces infos et le temps pris ...ça marche extra

mais quand j'essaye sur un fichier avec 34118 lignes ...

j'ai un message " l'indice n'appartient pas à la sélection"...

je vois ce soir à tête reposée et reviens si nécessaire

encore merci

103-6-2019-exel-pratique-transferer-des-lignes-en-fonction-du-mois.xlsm (32.59 Ko)
Le 03/06/2019 à 20:54

Bonjour

Certes !

Mais où intervient ce message ? (Quelle ligne de code)

Car si le code fonctionne sur les 34117 premières lignes il devrait réussir aussi au delà de la 34118ème

Je te concède que j'ai écrit le code un peu "à main levée", mais je l'ai testé il doit fonctionner, même s'il peut s'avérer un peu lent sur un gros volume de lignes, parce que pas du tout optimisé !

Le 04/06/2019 à 09:16

le forum

Gli73

c'est ok

ça tourne

merci et très bonne journée

cordialement

tomatito37

Le 04/06/2019 à 09:25

Bonjour

tomatito37 a écrit :

c'est ok/ça tourne

c'est parfait et tant mieux !
tomatito37 a écrit :

merci et très bonne journée

à toi aussi

Juste pour info...

1) quel était le problème à partir de la 34118ème ligne ?

2) combien de temps pour ton "jeu de données" réel ? sur combien de lignes ?

Le 04/06/2019 à 11:23

salut Gli73

j'ai ce message dès que je lance la macro sur le fichier que je reçois ( j'ai copié la macro sur la feuille 1 )

ce que j'ai fait :

en voyant que le fichier test ( nombre limité de lignes) fonctionne, j'ai copié les données ( 28144 lignes )que je reçois dans le premier onglet du fichier test

ainsi ça fonctionne

je viens de refaire le test ce matin

comment procéder pour connaître le temps nécessaire ?

Le 04/06/2019 à 12:48

Bonjour

Tu peux utiliser la fonction "Timer" comme ceci :

1) En première ligne du code juste avant celle-ci :

Set wsBase = Worksheets("données ")

Tu entres

temps=Timer

2) En dernière ligne du code, juste après celle-là :

Set wsBase = Nothing

Tu entres

MsgBox Timer - temps
Le 04/06/2019 à 14:49

42.21 secondes pour 28144 lignes

je viens de faire un autre test sur 56286 lignes : 85,80 secondes

c'est extra

merci pour ce partage de connaissances

Le 04/06/2019 à 14:54

(..)

A peine plus de 1'40sec. c'est pas mal

Et je pense que l'on peut faire mieux... je verrais ça à tête reposée !

Rechercher des sujets similaires à "transferer lignes fonction mois macro"