XL 2016 vba erreur de code reporting

douguy

XLDnaute Junior
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 !
 

Pièces jointes

  • Classeur1.xlsm
    2.6 MB · Affichages: 39

douguy

XLDnaute Junior
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
 

Pièces jointes

  • téléchargement.jpg
    téléchargement.jpg
    5.8 KB · Affichages: 39

Bebere

XLDnaute Barbatruc
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
Code:
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

XLDnaute Barbatruc
Bonjour le fil, le forum, douguy, Bebere

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

douguy

XLDnaute Junior
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
 

douguy

XLDnaute Junior
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

XLDnaute Barbatruc
bonsoir
Douguy à vérifier

Code:
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

XLDnaute Junior
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
 

douguy

XLDnaute Junior
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
 

Pièces jointes

  • Classeur1.xlsm
    3.5 MB · Affichages: 32

douguy

XLDnaute Junior
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
 

Discussions similaires

Réponses
8
Affichages
722
Réponses
1
Affichages
1 K

Statistiques des forums

Discussions
313 239
Messages
2 096 473
Membres
106 637
dernier inscrit
jpdupont