Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 vba erreur de code reporting

D

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
Trier par date Trier par votes
D

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
    5.8 KB · Affichages: 39
Vote positif 0 Vote négatif
B

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
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif
D

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
 
Vote positif 0 Vote négatif
B

Bebere

XLDnaute Barbatruc
bonjour
Douguy
à tester
Code: 
            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)
 
Dernière édition:
Vote positif 0 Vote négatif
D

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
 
Vote positif 0 Vote négatif
B

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
 
Vote positif 0 Vote négatif
D

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
 
Vote positif 0 Vote négatif
D

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
Vote positif 0 Vote négatif
B

Bebere

XLDnaute Barbatruc
Douguy il faut déplacer la ligne a=... et la mettre comme suit
Code: 
    a = Feuil17.Range("A6" & Mid(adr, 3)).Value 'tableau avec dates et valeurs
        .PivotFields("DATE").ClearLabelFilters
fait un mauvais copier/coller,excuses
 
Vote positif 0 Vote négatif
D

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
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Résolu(e)
XL 2021 calcul de l'heure quand le soleil est au Zénith
3 4 5
Réponses
64
Affichages
2 K
dysorthographie
G
  • Résolu(e)
XL 2021 VBA dates au mauvais format
Réponses
5
Affichages
252
vgendron
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 K
Nicolas JACQUIN
N
  • Question
Microsoft 365 appel des sous-routine
Réponses
3
Affichages
204
Dranreb
M
  • Question
Microsoft 365 Modifier code et format textbox
2 3
Réponses
35
Affichages
2 K
Marvin57
M
  • Résolu(e)
Microsoft 365 VBA : Calculer la date de fin de trimestre
2 3
Réponses
30
Affichages
3 K
eCHO
E
E
  • Question
Microsoft 365 VBA Calendrier, rien ne se passe.
Réponses
12
Affichages
937
fanch55
U
  • Résolu(e)
Autres Mettre en couleur ligne avec VBA car MFC occupées (Excel 2003)
2
Réponses
15
Affichages
1 K
un internaute
U
D
  • Question
Microsoft 365 Modification d'un code VBA
Réponses
8
Affichages
882
Hasco
  • Question
Microsoft 365 Simplification de code
Réponses
1
Affichages
1 K
GADENSEB
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…