Transférer des lignes en fonction du mois (macro)
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
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 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
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 forum
Gli73
c'est ok
ça tourne
merci et très bonne journée
cordialement
tomatito37
Bonjour
c'est parfait et tant mieux !c'est ok/ça tourne
merci et très bonne journée
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 ?
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 ?
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
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
(..)
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 !