récupération de données dans un tableau ne possédant pas les memes abscisses et ordon

L

lio62

XLDnaute Nouveau
BONSOIR

J'ai une feuille excel "bd" de laquelle je veux extraire les données en fonction du travail fait (depannage entretien ou contrôle) et de la date (moi et année) et qu'il aille recopier les données sur un autre tableau qui comporte
en ligne les années et en colonnes les mois de l'année j'arrive à récupérer les données mais pas a les placer au bon endroit sur le tableau.
je précise que dans la base de données les dates sont sous cette forme (JJ/MM/AAAA)

Code: 
Sub stats_TOTO()
Dim i As Integer
Dim regions
Dim Nol As Integer
Dim montableau(3) As String
Sheets("feuil1").Activate
With Application.ActiveSheet
.Range("b1").Value = "MOIS"

montableau(1) = "DEPANNAGE"
montableau(2) = "ENTRETIEN"
montableau(3) = "CONTROLE"

Range("b3:f3").Value = Array("B1", "B2", "B3", "B4", "B5")
 Range("B3:F3").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
        .Interior.ColorIndex = 6
End With
For i = 1 To 3
Cells(i + 3, 1).Value = montableau(i)
Next



'format de cellules
'Range("b4:e7").NumberFormat = "# ##0.00 €"
Range("a7").Value = "TOTAUX"
'nomme les cellules contenant les totaux
'affecte une formule aux cellules nommées
Range("b7").Name = "total1"
Range("total1").Formula = "=sum(b4:b6)"
Range("c7").Name = "total2"
Range("total2").Formula = "=sum(c4:c6)"
Range("d7").Name = "total3"
Range("total3").Formula = "=sum(d4:d6)"
Range("e7").Name = "total4"
Range("total4").Formula = "=sum(e4:e6)"
Range("f7").Name = "total5"
Range("total5").Formula = "=sum(f4:f6)"

End With
Range("A7:F7").Select
With Selection
        .Font.Bold = True
End With
encadrement

Call mois
End Sub

Sub mois()
Dim tabonglet As Variant
Dim onglet As String
Dim n As Long
Dim j As Byte, w As Byte
Dim a As Integer, b As Integer, c As Integer, d As Integer, e As Integer, f As Integer, g As Integer, h As Integer, r As Integer
Dim DATE1 As Long
Dim DATE2 As Long


Dim rng As Range

tabonglet = Array("DEPANNAGE", "ENTRETIEN", "CONTROLE")
w = 4
For j = 0 To UBound(tabonglet)
Sheets("bd").Activate

onglet = tabonglet(j)
    a = 0
    b = 0
    c = 0
    d = 0
    e = 0
    f = 0
    g = 0
    h = 0
        DATE1 = (Year([ao1])) + Month([ao1])
        
    With Worksheets("bd")
        .Range("a2").Activate
        .Range("a2").End(xlDown).Select
        Set rng = ActiveCell
        For n = 2 To rng.Row
    DATE2 = (Year(.Range("b" & n))) + Month(.Range("b" & n))

            If .Range("a" & n) = onglet And .Range("x" & n) Like "B1" And DATE1 = DATE2 Then a = a + 1
            If .Range("a" & n) = onglet And .Range("x" & n) Like "B2" And DATE1 = DATE2 Then d = d + 1
            If .Range("a" & n) = onglet And .Range("x" & n) Like "B3" And DATE1 = DATE2 Then b = b + 1
            If .Range("a" & n) = onglet And .Range("x" & n) Like "B4" And DATE1 = DATE2 Then c = c + 1
            If .Range("a" & n) = onglet And .Range("x" & n) Like "B5" And DATE1 = DATE2 Then g = g + 1
            'If .Range("av" & n) Like "*melor*" Then d = d + 1
            'If .Range("av" & n) Like "*melec*" Then e = e + 1
            'If .Range("av" & n) Like "*melim*" Then f = f + 1
            'If .Range("av" & n) Like "*melimpa*" Then g = g + 1
             
        Next n
        Sheets("feuil1").Range("b" & w) = a   ' 
        Sheets("feuil1").Range("c" & w) = d   ' 
        Sheets("feuil1").Range("d" & w) = b   ' 
        Sheets("feuil1").Range("e" & w) = c  ' 

         Sheets("feuil1").Range("f" & w) = g   '
              
        
        w = w + 1
    End With
Next j

Worksheets("bd").Range("S1").Activate
End Sub


     Sub encadrement()
     Dim i As Integer
    ThisWorkbook.Names("plage1").RefersToRange.Select
     For i = 1 To 4: Selection.Borders(i).LineStyle = xlContinuous: Next i
     End Sub
 

Sub annuel_rav()
Dim i As Integer, j As Integer

'Dim regions
'Dim Nol As Integer
Dim montableau(12) As String
Sheets("feuil1").Activate
With Application.ActiveSheet
.Range("b10").Value = "DEPANNAGE"

montableau(1) = "janvier"
montableau(2) = "février"
montableau(3) = "mars"
montableau(4) = "avril"
montableau(5) = "mai"
montableau(6) = "juin"
montableau(7) = "juillet"
montableau(8) = "août"
montableau(9) = "septembre"
montableau(10) = "octobre"
montableau(11) = "novembre"
montableau(12) = "décembre"


Range("b12:g12").Value = Array("2005", "2006", "2007", "2008", "2009", "2010")
 Range("B12:g12").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
        .Interior.ColorIndex = 43
End With
For i = 1 To 12
Cells(i + 12, 1).Value = montableau(i)
Next



'format de cellules
'Range("b4:e7").NumberFormat = "# ##0.00 €"
Range("a25").Value = "TOTAUX"
'nomme les cellules contenant les totaux
'affecte une formule aux cellules nommées
Range("b25").Name = "total11"
Range("total11").Formula = "=sum(b13:b24)"
Range("c25").Name = "total21"
Range("total21").Formula = "=sum(c13:c24)"
Range("d25").Name = "total31"
Range("total31").Formula = "=sum(d13:d24)"
Range("e25").Name = "total41"
Range("total41").Formula = "=sum(e13:e24)"
Range("f25").Name = "total51"
Range("total51").Formula = "=sum(f13:f24)"
Range("g25").Name = "total61"
Range("total61").Formula = "=sum(g13:g24)"
End With
Range("A25:g25").Select
With Selection
        .Font.Bold = True
End With
    ThisWorkbook.Names("plage2").RefersToRange.Select
     For j = 1 To 4: Selection.Borders(j).LineStyle = xlContinuous: Next j
     

'Call mois


End Sub

Sub annee_DEPANNAGE()
Dim tabonglet As Variant
Dim tabonglet2 As Variant
Dim onglet As String
Dim onglet2 As String
Dim n As Long
Dim j As Byte, w As Byte ', k As Byte

Dim a As Integer, b As Integer, c As Integer, d As Integer, e As Integer, f As Integer, g As Integer, h As Integer, r As Integer
Dim DATE1 As Long
Dim DATE2 As Long
'Dim date3 As Long


Dim rng As Range
tabonglet = Array("DEPANNAGE")
w = 13
For j = 0 To UBound(tabonglet)

Sheets("bd").Activate

onglet = tabonglet(j)
    a = 0
    b = 0
    c = 0
    d = 0
    e = 0
    f = 0
    g = 0
    h = 0
        DATE1 = (Year([ao1])) + Month([ao1])
        
    With Worksheets("bd")
        .Range("a2").Activate
        .Range("a2").End(xlDown).Select
        Set rng = ActiveCell
        For n = 2 To rng.Row
 DATE2 = (Year(.Range("b" & n))) + Month(.Range("b" & n))
          


            If .Range("a" & n) = onglet And DATE1 = DATE2 Then a = a + 1
                                 
        Next n
        'For k = 0 To (tabonglet2)
        'onglet2 = tabonglet2(k)
'tabonglet2 = Array("janvier", "février", "mars", "avril", "mai", "juin", "juillet", "août", "septembre", "octobre", "novembre", "décembre")


        Sheets("feuil1").Range("d" & w) = a  ' 2007
       ' Sheets("feuil1").Range("c" & w) = d   ' onduleur
       ' Sheets("feuil1").Range("d" & w) = b   ' imprimante
        'Sheets("feuil1").Range("e" & w) = c  ' imprimante partage
        ' Sheets("feuil1").Range("f" & w) = g   '
        'Sheets("feuil1").Range("c18") = d
        'Sheets("feuil1").Range("d18") = e
        ''Sheets("feuil1").Range("e18") = f
        'Sheets("feuil1").Range("f18") = g
       
        
        w = w + 1
    End With
   
Next j
 'Next k
Worksheets("bd").Range("S1").Activate
End Sub

merci a+
 
Trier par date Trier par votes
Pierrot93

Pierrot93

XLDnaute Barbatruc
Re : récupération de données dans un tableau ne possédant pas les memes abscisses et ordon

Bonsoir Lio

Quelle est la question ? Tu bloques quelque part dans ton code ?

Peut être qu'un fichier en pièce jointe nous aiderait à t'aider.

bonne soirée
@+
 
Vote positif 0 Vote négatif
jeanpierre

jeanpierre

Nous a quitté
Repose en paix
Re : récupération de données dans un tableau ne possédant pas les memes abscisses et ordon

Bonsoir lio62, le forum,

Ton code est bien... pas analysé, mais hors de son contexte, c'est pas vraiment simple.

Un petit fichier joint de ton souci et avec ce code serait plutôt bien...

Bonne soirée.

Jean-Pierre

Edit : Oh là, salut Pierrot, faut vraiment pas être déranger.....
 
Dernière édition:
Vote positif 0 Vote négatif
L

lio62

XLDnaute Nouveau
Re : récupération de données dans un tableau ne possédant pas les memes abscisses et ordon

BONJOUR,

j'ai joint le fichier, pour infos on lance par le module stat et c'est le dernier module "MAINTENANCE" qui me pose souci je voudrais récupérai les données de la feuille BD et qu'il me les recopie dans le tableau MAINTENANCE de la feuil1, au bon endroit. (dans l'exemple en FEVRIER 2007)

tout en sachant qu'il y aura deux autres tableaux DEPANNAGE et CONTROLE en dessous.

merci a+
 

Pièces jointes

  • FCDNDOWN2.zip
    42.2 KB · Affichages: 26
Vote positif 0 Vote négatif
L

lio62

XLDnaute Nouveau
Re : récupération de données dans un tableau ne possédant pas les memes abscisses et ordon

bonjour Pierrot, bonjour Jeanpierre

j'ai joins le fichier avez vous reussi a l'ouvri? car il est compressé avec winrar également

merci a+
 
Vote positif 0 Vote négatif

Discussions similaires

Chaton77
  • Résolu(e)
Microsoft 365 Vba : Transférer des données d'un tableau dans un autre fichier
Réponses
7
Affichages
320
Chaton77
Chaton77
lynyrd
  • Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
453
AtTheOne
AtTheOne
P
  • Question
XL 2019 Changer nom d'export en VBA
Réponses
3
Affichages
407
job75
job75
C
  • Résolu(e)
XL 2016 Répartir dans des Groupes d'Effectifs Aléatoires ... mais pas trop
Réponses
2
Affichages
202
crocrocro
C
M
  • Question
XL 2010 Remise et ajout de quantité
Réponses
10
Affichages
604
Dranreb
Dranreb
Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
831
Nicolas JACQUIN
Nicolas JACQUIN
F
  • Question
Microsoft 365 Poursuivre ou pas la macro
Réponses
2
Affichages
348
Francky79
F
B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
480
Compte Supprimé 979
C
Nicolas JACQUIN
  • Question
XL 2019 Fusionner jusqu'à dernière colonne contenant
Réponses
8
Affichages
563
TooFatBoy
TooFatBoy
D
  • Question
envois automatique d'email avec EXCEL et une MACRO
Réponses
4
Affichages
676
AtTheOne
AtTheOne

Membres actuellement en ligne

17 membres et 315 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 422
Messages
2 109 447
Membres
110 482
dernier inscrit
ilyxxxh