XL 2016 vba erreur de code reporting

[douguy]

Bonjour le Forum

Je viens vous voir pour un petit problème à corriger sur un code

Sub exportmec()

premierjour = DateSerial(year(Date), month(Date) - 1, 1)
dernierjour = DateSerial(year(Date), month(Date) + 12, 1) - 1

With Worksheets("pivotgroup").PivotTables("Tableau croisé dynamique1")
.PivotFields("DATE").ClearLabelFilters
.PivotFields("DATE").PivotFilters.Add Type:=xlDateBetween, Value1:="" & premierjour, Value2:="" & dernierjour
Haut = premierjour - DateSerial(year(Date), 1, 1) + 2 + 365
Bas = Date - DateSerial(year(Date), 1, 1) + 1 + 365
Nombre = .DataBodyRange.Rows.Count - 1
[Sheet3].Range([Sheet3].Cells(Haut, Bas), [Sheet3].Cells(Haut + Nombre - 1, Bas)).Value = .DataBodyRange.Columns(1).Resize(Nombre, 1).Cells.Value
[Sheet4].Range([Sheet4].Cells(Haut, Bas), [Sheet4].Cells(Haut + Nombre - 1, Bas)).Value = .DataBodyRange.Columns(2).Resize(Nombre, 1).Cells.Value
[Sh_MEC].Range([Sh_MEC].Cells(Haut, Bas), [Sh_MEC].Cells(Haut + Nombre - 1, Bas)).Value = .DataBodyRange.Columns(3).Resize(Nombre, 1).Cells.Value
[Sh_MEC1].Range([Sh_MEC1].Cells(Haut, Bas), [Sh_MEC1].Cells(Haut + Nombre - 1, Bas)).Value = .DataBodyRange.Columns(4).Resize(Nombre, 1).Cells.Value

.PivotFields("DATE").ClearLabelFilters
End With



End Sub



j'ai un onglet source avec pleins de dates et d'infos et j'ai un code qui me permet de récupérer les infos qui m'intéressent par rapport aux dates et les colle dans 4 nouveaux onglets (la source est un TCD qui se met à jour quotidiennement donc l'idée c'est de "sauvegarder" le TCD chaque jour (dates en ligne 1) et de les coller entre 2 bornes (sur 13 mois coulissants)

Mon problème est que lorsqu'il y a "des trous" dans les dates (par exemple on passe du 24 septembre au 26) le copier coller se fait mal et crée un décalage

Est ce que quelqu'un aurait une idée pour corriger ce problème?


Je vous joints les exemples

un grand merci d'avance !

 

[douguy]

re le forum !

Mon problème est donc le suivant :
La macro copie colle une plage.
Pour que cela fonctionne correctement, je me dis qu'il faudrait donc créer une macro qui
-compare les plages de dates continues
-copie colle en conséquence
-boucle sur la plage suivante
-copie colle en conséquence etc

la question est donc :
Quelqu'un sait il faire ça et a trop envie de m'aider ???
Pleaaaase helpp

gros bisous

 

[Bebere]

bonjour
Doughy bienvenue
une recherche sur le forum t'aurait donner une réponse
recherche avec find à tester
il y a d'autres méthodes une boucle,avec match(equiv),etc
sheet3 n'a pas besoin de crochet,c'est le codename de la feuille BDD MEC GROUPE
idem pour les autres

Sub exportmec()
    Dim Cel As Range
    Set Cel = Feuil17.Cells.Find(what:=Date, LookIn:=xlFormulas)

    If Not Cel Is Nothing Then
        premierjour = DateSerial(Year(Date), Month(Date) - 1, 1)
        dernierjour = DateSerial(Year(Date), Month(Date) + 12, 1) - 1
        With Worksheets("pivotgroup").PivotTables("Tableau croisé dynamique1")
            .PivotFields("DATE").ClearLabelFilters
            .PivotFields("DATE").PivotFilters.Add Type:=xlDateBetween, Value1:="" & premierjour, Value2:="" & dernierjour
            Haut = premierjour - DateSerial(Year(Date), 1, 1) + 2 + 365
            Bas = Date - DateSerial(Year(Date), 1, 1) + 1 + 365
            Nombre = .DataBodyRange.Rows.Count - 1
            [Sheet3].Range([Sheet3].Cells(Haut, Bas), [Sheet3].Cells(Haut + Nombre - 1, Bas)).Value = .DataBodyRange.Columns(1).Resize(Nombre, 1).Cells.Value
            [Sheet4].Range([Sheet4].Cells(Haut, Bas), [Sheet4].Cells(Haut + Nombre - 1, Bas)).Value = .DataBodyRange.Columns(2).Resize(Nombre, 1).Cells.Value
            [Sh_MEC].Range([Sh_MEC].Cells(Haut, Bas), [Sh_MEC].Cells(Haut + Nombre - 1, Bas)).Value = .DataBodyRange.Columns(3).Resize(Nombre, 1).Cells.Value
            [Sh_MEC1].Range([Sh_MEC1].Cells(Haut, Bas), [Sh_MEC1].Cells(Haut + Nombre - 1, Bas)).Value = .DataBodyRange.Columns(4).Resize(Nombre, 1).Cells.Value
            .PivotFields("DATE").ClearLabelFilters
        End With

    End If

End Sub

 

[Staple1600]

Bonjour le fil, le forum, douguy, Bebere

Juste histoire de...

Sub VarierLesPlaisirs()
premierjour = CDate("1/" & Month(DateAdd("m", -1, Date)))
dernierjour = CDate(Application.EoMonth(Date, 11))
MsgBox premierjour
MsgBox dernierjour
End Sub

 

[douguy]

bonjour Bebere et Staple et merci d'avoir apporté des éléments de réponse.

Malheureusement mes compétences VBA sont nulles et donc un peu dur de travailler dessus.
Mon problème c'est que dans le TCD il y a des dates sans valeurs (ca c'est pas un souci) mais il y a surtout des dates qui n'existent pas encore (par exemple on passe du 24 septembre au 26, mais un jour la date du 25 va se créer)
du coup le copier coller est flingué car en recopiant les valeurs on se retrouve avec des données au 25 alors qu'il aurait fallut sauter une cellule !

je ne sais pas si je suis assez clair mais ce qui est sur c'est que j'ai besoin de vos lumières

Merci

 

[Bebere]

bonjour
Douguy
à tester

            Bas = Sheet3.Rows(1).Find(what:=Date, LookIn:=xlFormulas).Column 'Date - DateSerial(Year(Date), 1, 1) + 1 + 365

ou alors comme dans haut +2( +1 en rouge)

 

[douguy]

bonjour Bébere

Malheureusement ce n'est pas ça.
Je cherche du coté du TCD. C'est dans sa structure que ca pose problème. Le fait que des dates manquent.

J'imagine la possibilité d'utiliser un formulalocal.(index (equiv (equiv )))

mais ca va alourdir la procédure beaucoup....

je suis preneur d'autres idées

 

[Bebere]

bonsoir
Douguy à vérifier

Sub exportmec()
    Dim a(), b(), x(), y(), ws As Worksheet

    premierjour = DateSerial(Year(Date), Month(Date) - 1, 1)
    dernierjour = DateSerial(Year(Date), Month(Date) + 12, 1) - 1
    haut = premierjour - DateSerial(Year(Date), 1, 1) + 2 + 365
    bas = Date - DateSerial(Year(Date), 1, 1) + 1 + 365
    x = Array("BDD MEC GROUPE", "BDD CA GROUPE", "BDD MEC INDIV", "BDD CA INDIV")
    y = Array(2, 3, 4, 5)
    With Worksheets("pivotgroup").PivotTables("Tableau croisé dynamique1")
        .PivotFields("DATE").ClearLabelFilters
        .PivotFields("DATE").PivotFilters.Add Type:=xlDateBetween, Value1:="" & premierjour, Value2:="" & dernierjour
        Nombre = .DataBodyRange.Rows.Count - 1
        adr = .DataBodyRange.Columns(1).Resize(Nombre, 5).Cells.Address(0, 0)
        .PivotFields("DATE").ClearLabelFilters
    End With

    a = Feuil17.Range("A6" & Mid(adr, 3)).Value 'tableau avec dates et valeurs
    For k = LBound(x) To UBound(x)
        Set ws = Sheets(x(k))
        b = ws.Range(ws.Cells(haut, 1), ws.Cells(bas, 1)).Value    'date
        ReDim c(1 To UBound(b, 1), 1 To 1) 'pour valeur
        For i = 2 To UBound(a, 1)
            For l = 1 To UBound(b, 1)
                If b(l, 1) = a(i, 1) Then
                    If a(i, y(k)) <> "" Then
                        c(l, 1) = a(i, y(k))    'valeur
                    End If
                End If
            Next l
        Next i
        ' f = ws.Rows(1).Find(what:=premierjour, LookIn:=xlFormulas).Column
        ws.Cells(haut, haut).Resize(UBound(c, 1), 1) = c
    Next k
   
End Sub

 

[douguy]

woah !
ca devient costaud
merci bcp Bébère

j'ai un problème de "erreur d'execution 9" " l'indice n'appartient pas a la sélection" sur la ligne "set ws = sheets(x(k))"

le code est un peu trop complexe pour que je comprenne ce qu'il se passe.
On a bien le nom de la feuille qui s'inscrit mais je ne comprend pas plus...

désolé d'être mauvais en VBA

cordialement

 

[Bebere]

doughy essaye comme suit Set ws = Sheets(CStr(x(k)))
bien déclaré les variables est important

 

[douguy]

nope !
même problème
la déclaration se fait bien Set ws = sheets(BDD CA GROUPE) mais ca bug sur " l'indice n'appartient pas a la sélection"

 

[Bebere]

bonjour
Douguy regarde si les noms des feuilles sont bien les mêmes
regarde du côté des espaces dans le nom des feuilles

 

[douguy]

Oui en effet il y avait un espace qui faisait bugger le truc.
la macro tourne mais rien ne se passe !
elle s'exécute en un clin d'oeil mais rien ne s'écrit


bonne journée bébère

 

[Bebere]

Douguy il faut déplacer la ligne a=... et la mettre comme suit

    a = Feuil17.Range("A6" & Mid(adr, 3)).Value 'tableau avec dates et valeurs
        .PivotFields("DATE").ClearLabelFilters

fait un mauvais copier/coller,excuses

 

[douguy]

merci Bebere, merci vraiment à toi de m'aider!
du coup ca donne ca dans le code !???
j'ai remonté la ligne a= là ou je pense que c'est bon !
cependant il ne se passe toujours rien


Sub exportmec()
Dim a(), b(), x(), y(), ws As Worksheet

premierjour = DateSerial(Year(Date), Month(Date) - 1, 1)
dernierjour = DateSerial(Year(Date), Month(Date) + 12, 1) - 1
haut = premierjour - DateSerial(Year(Date), 1, 1) + 2 + 365
bas = Date - DateSerial(Year(Date), 1, 1) + 1 + 365
x = Array("BDD MEC GROUPE", "BDD CA GROUPE", "BDD MEC INDIV", "BDD CA INDIV")
y = Array(2, 3, 4, 5)
With Worksheets("pivotgroup").PivotTables("Tableau croisé dynamique1")
.PivotFields("DATE").ClearLabelFilters
.PivotFields("DATE").PivotFilters.Add Type:=xlDateBetween, Value1:="" & premierjour, Value2:="" & dernierjour
Nombre = .DataBodyRange.Rows.Count - 1
adr = .DataBodyRange.Columns(1).Resize(Nombre, 5).Cells.Address(0, 0)
a = Feuil17.Range("A6" & Mid(adr, 3)).Value 'tableau avec dates et valeurs
.PivotFields("DATE").ClearLabelFilters
End With


For k = LBound(x) To UBound(x)
Set ws = Sheets(CStr(x(k)))
b = ws.Range(ws.Cells(haut, 1), ws.Cells(bas, 1)).Value 'date
ReDim c(1 To UBound(b, 1), 1 To 1) 'pour valeur
For i = 2 To UBound(a, 1)
For l = 1 To UBound(b, 1)
If b(l, 1) = a(i, 1) Then
If a(i, y(k)) <> "" Then
c(l, 1) = a(i, y(k)) 'valeur
End If
End If
Next l
Next i
'f = ws.Rows(1).Find(what:=premierjour, LookIn:=xlFormulas).Column
ws.Cells(haut, haut).Resize(UBound(c, 1), 1) = c
Next k

End Sub