adapter macro

christine854

XLDnaute Junior
bonjour a tous

j'ai une macro que je souhaite adapter pour un fichier

j'ai commencé a l'adapté mais je coince sur certains point
voici la macro
Option Explicit

Dim tablo, fb As Worksheet, ft As Worksheet, cell As Range, dte As Date, i&

Sub CONDITION ()
'on defini les variables
Dim Valeur_Test As String
Dim DerniereLigne As Integer
Dim Lig

Set ft = Sheets("TEST_VALIDATION")
Set fb = Sheets("STOCKAGE_DES_DONNEES")
'pour une lecture plus rapide des données dans le tableau résultat
tablo = ft.Range("Q2:Y" & ft.Range("Q" & Rows.Count).End(xlUp).Row)


For i = 2 To UBound(tablo, 1)
Set cell = fb.Range("A2:A" & fb.Range("A" & Rows.Count).End(xlUp).Row).Find(tablo(i, 1), LookAt:=xlWhole)
If Not cell Is Nothing Then
If IsDate(cell.Offset(0, 1)) Then
'Si le test est ok alors on test la Premières condition
If tablo(i, 25) = "L" Or "J" _
And Month(cell.Offset(0, 1)) = Month(Date) _
And Year(cell.Offset(0, 1)) = Year(Date) Then
fb.Range("C" & cell.Row & ":H" & cell.Row).Delete shift:=xlUp
cell.Offset(0, 1) = DateSerial(Year(cell.Offset(0, 1)), Month(cell.Offset(0, 1)) + 5, 1)

'puis la Deuxièmes conditions
ElseIf tablo(i, 25) = "K" And Month(cell.Offset(0, 1)) = Month(Date) _
And Year(cell.Offset(0, 1)) = Year(Date) Then
ft.Range("Q" & i & ":Y" & i).Copy ft.Range("AD" & i)
cell.Offset(0, 1) = "cumule " & cell.Offset(0, 1)

End If

'puis la Troisièmes conditions
ElseIf tablo(i, 19) > 80 And cell.Offset(0, 1) Like "cumule*" Then
fb.Range("C" & cell.Row & ":H" & cell.Row).Delete shift:=xlUp
cell.Offset(0, 1) = DateSerial(Year(Date), Month(Date) + 5, 1)



End If
'on test si l'identifiant existe Sinon, on l'ajoute à la liste avec la date de fin
Else
Cells(DerniereLigne + 1, 1).Value = Valeur_Test
End If

Next i

End Sub


je coince sur : (j'ai mis des commentaire a coté des ligne ou je coince)


For i = 2 To UBound(tablo, 1)
Set cell = fb.Range("A2:A" & fb.Range("A" & Rows.Count).End(xlUp).Row).Find(tablo(i, 1), LookAt:=xlWhole)
If Not cell Is Nothing Then
If IsDate(cell.Offset(0, 1)) Then


If tablo(i, 25) = "L" Or "J" _
And Month(cell.Offset(0, 1)) = Month(Date) _ 'doit tester dans la feuille fb
And Year(cell.Offset(0, 1)) = Year(Date) Then
fb.Range("C" & cell.Row & ":H" & cell.Row).Delete shift:=xlUp
cell.Offset(0, 1) = DateSerial(Year(cell.Offset(0, 1)), Month(cell.Offset(0, 1)) + 5, 1) 'doit saisir dans la feuille fb


ElseIf tablo(i, 25) = "K" And Month(cell.Offset(0, 1)) = Month(Date) _
And Year(cell.Offset(0, 1)) = Year(Date) Then 'la date est dans la feuille fb
ft.Range("Q" & i & ":Y" & i).Copy ft.Range("AD" & i)
cell.Offset(0, 1) = "cumule " & cell.Offset(0, 1) 'doit être saisie dans la feuille fb


ElseIf tablo(i, 19) > 80 And cell.Offset(0, 1) Like "cumule*" Then 'cumule est dans la feuille fb
fb.Range("C" & cell.Row & ":H" & cell.Row).Delete shift:=xlUp
cell.Offset(0, 1) = DateSerial(Year(Date), Month(Date) + 5, 1) 'saisie de la date dans la feuille fb

la ou j'ai mis des commentaires c'est là ou j'ai mes données mais je ne suis pas sur que dans les conditions ça correspond bien
 

Modeste

XLDnaute Barbatruc
Re,

Il y a des choses non-cohérentes entre ton dernier schéma et le code de ton message #43 pour les cas des "L" ou "J" avec mention "cumule" :confused:
J'avais, après avoir déposé le code précédent, remanié un peu ce dernier pour gagner un peu en temps d'exécution (en stockant dans des tableaux en mémoire, les 3 plages à recopier en colonnes AD, AN et AX.

Le code ci-dessous tient compte de ce que j'ai cru comprendre (mais je ne suis pas bien certain!?). Je te laisse faire des tests pour vérifier ...
VB:
Sub Oulala()

Dim tabloL(), tabloJ(), tabloK()
ligL = 1
ligJ = 1
ligK = 1
tabloValid = Feuil1.Range("Q2:Y" & Feuil1.Cells(Rows.Count, 17).End(xlUp).Row)
ReDim tabloL(1 To UBound(tabloValid), 1 To 8)
ReDim tabloJ(1 To UBound(tabloValid), 1 To 8)
ReDim tabloK(1 To UBound(tabloValid), 1 To 8)
Application.ScreenUpdating = False
For i = 1 To UBound(tabloValid)
    With Feuil2
        'si identifiant pas présent en stockage
        If Application.CountIf(.[A:A], tabloValid(i, 1)) = 0 Then
             .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = tabloValid(i, 1)
             .Cells(Rows.Count, 1).End(xlUp).Offset(0, 1) = DateSerial(Year(Date), Month(Date) + 5, 1) '+3 ou +5??
        Else
             'trouver ligne de l'identifiant col A de Test_Validation
            ligneID = Application.Match(tabloValid(i, 1), .[A:A], 0)
            If tabloValid(i, 9) = "J" Or tabloValid(i, 9) = "L" Then
                If .Cells(ligneID, 2) = DateSerial(Year(Date), Month(Date) - 1, 1) Then
                    'supprimer toutes occurrences de l'identifiant col D à I
                    For lig = .Cells(Rows.Count, 4).End(xlUp).Row To 2 Step -1
                        If .Cells(lig, 4) = tabloValid(i, 1) Then .Cells(lig, 4).Resize(1, 6).Delete Shift:=xlUp
                    Next lig
                    'supprimer toutes occurrences de l'identifiant col K à M
                    For lig = .Cells(Rows.Count, 11).End(xlUp).Row To 2 Step -1
                        If .Cells(lig, 11) = tabloValid(i, 1) Then .Cells(lig, 11).Resize(1, 3).Delete Shift:=xlUp
                    Next lig
                End If
                'traitement des lignes avec mention cumule
                If .Cells(ligneID, 3) = "cumule" And .Cells(ligneID, 2) = DateSerial(Year(Date), Month(Date) - 1, 1) Then
                    .Cells(ligneID, 3) = ""
                    .Cells(ligneID, 2) = DateSerial(Year(Date), Month(Date) + 3, 1)
                End If

                If tabloValid(i, 9) = "L" And .Cells(ligneID, 2) = DateSerial(Year(Date), Month(Date) - 1, 1) Then
                   For x = 1 To 8
                       tabloL(ligL, x) = tabloValid(i, x)
                   Next x
                   ligL = ligL + 1
                ElseIf tabloValid(i, 9) = "J" And .Cells(ligneID, 2) = DateSerial(Year(Date), Month(Date) - 1, 1) Then
                   For x = 1 To 8
                       tabloJ(ligJ, x) = tabloValid(i, x)
                   Next x
                   ligJ = ligJ + 1
                End If
            ElseIf tabloValid(i, 9) = "K" And .Cells(ligneID, 2) = DateSerial(Year(Date), Month(Date) - 1, 1) Then
                'ajouter mention "cumule" + date + 3 mois
                .Cells(ligneID, 3) = "cumule"
                .Cells(ligneID, 2) = DateSerial(Year(Date), Month(Date) + 3, 1)
               For x = 1 To 8
                   tabloK(ligK, x) = tabloValid(i, x)
               Next x
               ligK = ligK + 1
            End If
        End If
     End With
Next i
'copier en colonne AD et suivantes
Feuil1.Cells(Rows.Count, 30).End(xlUp).Offset(1, 0).Resize(ligL, 8) = tabloL
'copier en colonne AN et suivantes
Feuil1.Cells(Rows.Count, 40).End(xlUp).Offset(1, 0).Resize(ligJ, 8) = tabloJ
'copier les données de Q à X en colonnes AX et suivantes
Feuil1.Cells(Rows.Count, 50).End(xlUp).Offset(1, 0).Resize(ligK, 8) = tabloK

Application.ScreenUpdating = True
End Sub
 

Modeste

XLDnaute Barbatruc
Bonsoir,

Je présume que tu feras un compte-rendu de ce qui fonctionne (ou non) un peu plus détaillé et circonstancié. Je te lirai donc avec intérêt ... mais sans doute plus aujourd'hui

Bonne nuit au petit monde du forum (re-)coloré :)
 

Modeste

XLDnaute Barbatruc
Ouahhh hé, revenir à la charge après 10 jours ... j'ai tout oublié de ton fichier, moi! Déjà quand on y baigne, c'est pas évident de s'y retrouver!

Force m'est tout de même de constater qu'en colonne B de tes fichiers précédents (en feuille "Stockage des données"), toutes les dates correspondaient au premier jour du mois. Ici, les dates représentées vont chaque fois du 1 au 30 ou 31 ... erreur de manipulation? J'espère que ce n'est que ça!!
 

Modeste

XLDnaute Barbatruc
Bonsoir christine 854 (si ça continue, on va en arriver à 854 messages!! ... Manque plus que le 8 devant)

Tu te souviendras que la dernière fois, j'ai dit que c'était difficile de replonger dans ton fichier (tu reconnaîtras que c'est pas tous les jours qu'on travaille sur 4 tableaux distincts dont une partie des données seulement est commune, mais entre lesquels il faut établir des liens!?)
Je veux donc bien faire des efforts, considérer que tu n'avais pas d'autre façon de travailler et continuer de chercher des solutions, mais en contre partie, tu dois faire l'effort d'expliquer (tu as l'art de "faire court"), de mettre ton fichier test à disposition (ce n'est pas à nous d'aller rectifier les dates, tu en seras d'accord?) et de repréciser (oui, j'ai la comprenette un peu laborieuse: il faut beaucoup répéter!) dans tel cas, il faudrait tel résultat, parce qu'on est dans tel cas de figure. Pour cet autre cas, on devrait obtenir ceci, pour telle raison, etc...

Peut-être que comme ça, on y arrivera!?
 

christine854

XLDnaute Junior
en faite pour finaliser mes test manque juste cette partie que je n'ai pas vu dans le code (je suis pas en mesure de l'affirmer au vu de mon niveau)
c'est : dans les conditions pour J et L il manque la modif de date je ne l'avais pas vu la première fois mais quand tu as simplifié le schéma tu l'as enlevé
 

Modeste

XLDnaute Barbatruc
un grand merci pour ta patience (je suis pas la demande la plus simple en effet)
Ce qui est le plus terrible c'est que tu es sans doute pleine de bonne volonté, mais que tu ne réponds que rarement aux questions ou demandes.
Essaie ce qui suit (mais si ce n'est pas la bonne, ce sera ma dernière proposition ... sauf si tu y mets vraiment du tien pour nous aider!)
VB:
Sub Oulala()

Dim tabloL(), tabloJ(), tabloK()
ligL = 1
ligJ = 1
ligK = 1
tabloValid = Feuil1.Range("Q2:Y" & Feuil1.Cells(Rows.Count, 17).End(xlUp).Row)
ReDim tabloL(1 To UBound(tabloValid), 1 To 8)
ReDim tabloJ(1 To UBound(tabloValid), 1 To 8)
ReDim tabloK(1 To UBound(tabloValid), 1 To 8)
Application.ScreenUpdating = False
For i = 1 To UBound(tabloValid)
    With Feuil2
        'si identifiant pas présent en stockage
       If Application.CountIf(.[A:A], tabloValid(i, 1)) = 0 Then
             .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = tabloValid(i, 1)
             .Cells(Rows.Count, 1).End(xlUp).Offset(0, 1) = DateSerial(Year(Date), Month(Date) + 5, 1) '+3 ou +5??
       Else
             'trouver ligne de l'identifiant col A de Test_Validation
           ligneID = Application.Match(tabloValid(i, 1), .[A:A], 0)
            If tabloValid(i, 9) = "J" Or tabloValid(i, 9) = "L" Then
                If .Cells(ligneID, 2) = DateSerial(Year(Date), Month(Date) - 1, 1) Then
                    'supprimer toutes occurrences de l'identifiant col D à I
                   For lig = .Cells(Rows.Count, 4).End(xlUp).Row To 2 Step -1
                        If .Cells(lig, 4) = tabloValid(i, 1) Then .Cells(lig, 4).Resize(1, 6).Delete Shift:=xlUp
                    Next lig
                    'supprimer toutes occurrences de l'identifiant col K à M
                   For lig = .Cells(Rows.Count, 11).End(xlUp).Row To 2 Step -1
                        If .Cells(lig, 11) = tabloValid(i, 1) Then .Cells(lig, 11).Resize(1, 3).Delete Shift:=xlUp
                    Next lig
                    'ajout 06/11/2016
                    .Cells(ligneID, 2) = DateSerial(Year(Date), Month(Date) + 3, 1)
                End If
                'traitement des lignes avec mention cumule
               If .Cells(ligneID, 3) = "cumule" And .Cells(ligneID, 2) = DateSerial(Year(Date), Month(Date) - 1, 1) Then
                    .Cells(ligneID, 3) = ""
                    .Cells(ligneID, 2) = DateSerial(Year(Date), Month(Date) + 3, 1)
                End If

                If tabloValid(i, 9) = "L" And .Cells(ligneID, 2) = DateSerial(Year(Date), Month(Date) - 1, 1) Then
                   For x = 1 To 8
                       tabloL(ligL, x) = tabloValid(i, x)
                   Next x
                   ligL = ligL + 1
                ElseIf tabloValid(i, 9) = "J" And .Cells(ligneID, 2) = DateSerial(Year(Date), Month(Date) - 1, 1) Then
                   For x = 1 To 8
                       tabloJ(ligJ, x) = tabloValid(i, x)
                   Next x
                   ligJ = ligJ + 1
                End If
            ElseIf tabloValid(i, 9) = "K" And .Cells(ligneID, 2) = DateSerial(Year(Date), Month(Date) - 1, 1) Then
                'ajouter mention "cumule" + date + 3 mois
               .Cells(ligneID, 3) = "cumule"
                .Cells(ligneID, 2) = DateSerial(Year(Date), Month(Date) + 3, 1)
               For x = 1 To 8
                   tabloK(ligK, x) = tabloValid(i, x)
               Next x
               ligK = ligK + 1
            End If
        End If
     End With
Next i
'copier en colonne AD et suivantes
Feuil1.Cells(Rows.Count, 30).End(xlUp).Offset(1, 0).Resize(ligL, 8) = tabloL
'copier en colonne AN et suivantes
Feuil1.Cells(Rows.Count, 40).End(xlUp).Offset(1, 0).Resize(ligJ, 8) = tabloJ
'copier les données de Q à X en colonnes AX et suivantes
Feuil1.Cells(Rows.Count, 50).End(xlUp).Offset(1, 0).Resize(ligK, 8) = tabloK

Application.ScreenUpdating = True
End Sub
 

christine854

XLDnaute Junior
c'est nickel seul bug la copie ne se fait que pour "K" (dis moi si je me trompe ) mais si la date change (la ligne que tu as rajouté) avant le critére de copie
Code:
If tabloValid(i, 9) = "L" And .Cells(ligneID, 2) = DateSerial(Year(Date), Month(Date) - 1, 1)
c'est pour ça que la copie ne ce fait plus ?
quand je parle de la copie c'est de cette partie:
Code:
'copier en colonne AD et suivantes
Feuil3.Cells(Rows.Count, 30).End(xlUp).Offset(1, 0).Resize(ligL, 8) = tabloL
'copier en colonne AN et suivantes
Feuil3.Cells(Rows.Count, 40).End(xlUp).Offset(1, 0).Resize(ligJ, 8) = tabloJ
'copier les données de Q à X en colonnes AX et suivantes
Feuil3.Cells(Rows.Count, 50).End(xlUp).Offset(1, 0).Resize(ligK, 8) = tabloK

sinon c'est exactement ça
désolé pour les explication un peut confuse (je pense que ce n'est rien de le dire ) mais le sujet est complexe (même pour moi)
 

Modeste

XLDnaute Barbatruc
:rolleyes: C'est toujours aussi clair :rolleyes:
Ceci dit, à l'endroit où j'ai placé le code hier, je dois bien reconnaître que je modifiais les dates avant de vérifier si elles correspondaient au mois précédent ... ça ne risquait pas de marcher!
Supprime la ligne ajoutée hier et insère-la un peu plus bas à deux endroits:

  • juste avant ou juste après ligL = ligL + 1
  • et juste avant ou après ligJ = ligJ + 1

Et croise les doigts (parce que là, je fatigue un peu :confused:)
 

Discussions similaires

Statistiques des forums

Discussions
311 735
Messages
2 082 024
Membres
101 873
dernier inscrit
excellllll