Copie de données vers onglet spécifique en fonction de dates

Le 02/10/2017 à 11:21

Bonjour,

partant d'une macro ayant fait ses preuvres (jointe avec le fichier), j'ai un nouveau besoin.

J'ai des données en A1:B16 ayant en colonne A des dates comprises entre le 01/09/17 et le 31/12/2018.

Je souhaite que ces valeurs (de A1 à B16) soient recopiées vers l'onglet correspondant au mois dela colonne A).

J'ai donc crée 1 onglet pour chaque mois de septembre 2017 à décembre 2018.

La macro fournit (merci Dan !) fonctionne sur une période de 12 mois de l'année civile, maintenant la durée s"est allongée et il faut que je prenne en compte les 4 derniers mois de l'année N + les 12 mois de l'année N+1.

Merci de me venir en aide, je ne suis pas capable, à partir de la macro de Dan, de modifier pour obtenir quelquechose qui fonctionne.

27laa0nclasseur1.xlsx (48.72 Ko)
Le 02/10/2017 à 11:58

bonjour

humm comment je fait pour test ta macro

Feuille = Application.Proper(Format(Range("A" & I).Value, "mmmm yyyy"))

A+

Maurice

Le 02/10/2017 à 13:04

Bonjour Maurice,

j'ai remplacé la ligne "feuille" par ce que tu me proposes.

ça plante à la ligne du dessous (lg = sheets.....)

Je ne comprends rien à ce que je recopie.

j'ai remis le fichier avec la macro associée au bouton 3.

Merci pour ton aide.

27laa0nclasseur1.xlsm (59.97 Ko)
Le 02/10/2017 à 14:10

bonjour

ou se trouve l'onglet février 2009

A+

Maurice

Le 02/10/2017 à 16:42

Il n'y a plus d'onglet 2009.

Je travaille maintenant avec des données 2017 et 2018.

Si une référence a quelque chose de 2009 traîne ,c'est une erreur de ma part.

Le 05/10/2017 à 16:27

Bonjour à tous,

je me permets de relancer.

Quelqu'un pourrait-il voler à mon secours ?

A partir du fichier joint je souhaite que la macro déclenchée par le bouton 3 dispatche les données (contenant des dates) vers les onglets correspondant (1 onglet par mois de septembre 2017 à décembre 2018).

Ne prendre en compte que les cellules A1 à B16 (fond jaune)

Help please !!!

Le 05/10/2017 à 17:01

Bonjour olive7677

Quelque chose à tenter...

PS/ je n'ai pas compris si il faut écrire à la suite ou écraser les données existantes dans les onglet... donc j'écris à la suite !

Sub CopierVersion2017()
' Modification NCC 1701 pour olive7677 le 05/10/2017

' Une toute autre methode qui devrait permettre d'adapter au cas par cas
' au cas où il faudrait rallonger la periode...

Dim wsCalcul As Object
Dim wsColler As Object

Dim tabCopier()
Dim dateOnglet

    Set wsCalcul = Worksheets("calcul")
    With wsCalcul
        tabCopier = Range(.Cells(1, 1), .Cells(16, 2))
    End With

    For cpt = 1 To UBound(tabCopier, 1)
        dateOnglet = Application.Proper(Format(tabCopier(cpt, 1), "mmmm yyyy"))

        If Not ExisteOnglet(dateOnglet) Then
            ActiveWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
            ActiveWorkbook.Sheets(Sheets.Count).Name = dateOnglet
        End If

        Set wsColler = Worksheets(dateOnglet)
        With wsColler
            ligfin = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            .Cells(ligfin, 1) = tabCopier(cpt, 1)
            .Cells(ligfin, 2) = tabCopier(cpt, 2)
        End With
        Set wsColler = Nothing

    Next

    Set wsCalcul = Nothing

End Sub

Function ExisteOnglet(lequel)
Dim testOnglet

    On Error GoTo errExiste
    testOnglet = Worksheets(lequel).Cells(1, 1)
    On Error GoTo 0

    ExisteOnglet = True

    Exit Function

errExiste:
    On Error GoTo 0
    ExisteOnglet = False
End Function
Le 05/10/2017 à 21:02

Bonsoir NCC 1701,

un grand merci car effectivement je confirme que cela fonctionne (je viens de faire un petit test à la maison).

Je dois maintenant remettre à la sauce complète pour que ça fonctionne avec l'intégralité du fichier (au boulot...)

Je vais donc (TENTER lol) de modifier la macro car les données à dispatcher sont dans les cellules A2;Kn d'une part et que je ne lance la macro qu'une seule fois donc j'écrase ce qui peut être écrit précédemment.

J'espère simplement être plus performant pour parvenir au résultat sans (trop) solliciter d'aide.

Encore MERCI.

Sujet résolu

Le 05/10/2017 à 22:10

(re)

Parfait

Et merci pour

olive7677 a écrit :

un grand merci

et
olive7677 a écrit :

Encore MERCI.

Par contre voici une nouvelle version qui :

Efface les données lors du premier passage (seulement) dans le mois

Ecrit à la suite ensuite...

Parce que je redoutais effectivement

olive7677 a écrit :

je ne lance la macro qu'une seule fois donc j'écrase ce qui peut être écrit précédemment.

comme ça le code se charge de tout... et une manip de moins...! C'est toujours ça de gagné et surtout c'est fait pour ça un ordinateur 
Public cptPasse
Public tabPasse()

Sub CopierVersion2017()
' Modification NCC 1701 pour olive7677 le 05/10/2017

' Une toute autre methode qui devrait permettre d'adapter au cas par cas
' au cas où il faudrait rallonger la periode...

Dim wsCalcul As Object
Dim wsColler As Object

Dim tabCopier()
Dim dateOnglet
Dim ligFin

    cptPasse = 0
    ReDim tabPasse(1 To 1)

    Set wsCalcul = Worksheets("calcul")
    With wsCalcul
        tabCopier = Range(.Cells(1, 1), .Cells(16, 2))
    End With

    For cpt = 1 To UBound(tabCopier, 1)
        dateOnglet = Application.Proper(Format(tabCopier(cpt, 1), "mmmm yyyy"))

        If Not ExisteOnglet(dateOnglet) Then
            ActiveWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
            ActiveWorkbook.Sheets(Sheets.Count).Name = dateOnglet
        End If

        Set wsColler = Worksheets(dateOnglet)
        With wsColler
            ligFin = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            If Not DejaPasse(dateOnglet) Then
                Range(.Cells(2, 1), .Cells(ligFin, 2)).ClearContents
                ligFin = 2
            End If
            .Cells(ligFin, 1) = tabCopier(cpt, 1)
            .Cells(ligFin, 2) = tabCopier(cpt, 2)
        End With
        Set wsColler = Nothing

    Next

    Set wsCalcul = Nothing

End Sub

Function ExisteOnglet(lequel)
Dim testOnglet

    On Error GoTo errExiste
    testOnglet = Worksheets(lequel).Cells(1, 1)
    On Error GoTo 0

    ExisteOnglet = True

    Exit Function

errExiste:
    On Error GoTo 0
    ExisteOnglet = False
End Function

Function DejaPasse(quelOnglet)
Dim cpt
Dim trv

    cpt = 1
    trv = False
    While Not (cpt > UBound(tabPasse, 1)) And Not trv
        If tabPasse(cpt) = quelOnglet Then
            trv = True
        Else
            cpt = cpt + 1
        End If
    Wend

    If Not trv Then
        DejaPasse = False
        cptPasse = cptPasse + 1
        ReDim Preserve tabPasse(1 To cptPasse)
        tabPasse(cptPasse) = quelOnglet
    Else
        DejaPasse = True
    End If

End Function

et bon courage pour la suite

Rechercher des sujets similaires à "copie donnees onglet specifique fonction dates"