Microsoft 365 SI cellule vide dans la colonne A

Moreno076

XLDnaute Impliqué
Bonsoir le forum

Je souhaiterais adapter cette formule.
Si dans la colonne A case vide alors on applique cette formule et on ajoute en plus quantité de la colonne I sinon on laisse son contenu.
SI possible avec une petite variante, si 'RLR'!A:A = date du jour alors écrire "RECEPTIONNEE"

Range("A2").Formula = "=IFERROR(INDEX('RLR'!A:A,MATCH(B2,'RLR'!C:C,0)),"""")"
Range("A2:A" & Derlg).FillDown

Merci
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Bonsoir.
Je vous livre à tout hasard mon dernier code de la WshSynth (Synthèse)
VB:
Option Explicit
Private Sub Worksheet_Activate()
   Dim LOtDoc As ListObject, C As Long, L As Long, RngRenv As Range, TSrc(), CelTit As Range, RngDonn As Range, Wsh As Worksheet, _
      TSyn(), Code As SsGr, Détail, Dsgn As String, LDéb As Long, CEstLeDébut As Boolean, IlFautAvancer As Boolean, CEstUneSuite3ou4 As Boolean
      
Rem. — Analyse de la documentation.
   Set LOtDoc = WshDoc.ListObjects("TabDoc")
   For C = 2 To 5 ' Colonnes des sources.
      Set RngRenv = LOtDoc.ListColumns(C).DataBodyRange ' Récupère la colonne des renvois aux titres.
      For L = 1 To RngRenv.Rows.Count
         If RngRenv.Rows(L).HasFormula Then ' Pour chaque cellule portant une formule :
            Set CelTit = Evaluate(RngRenv.Rows(L).Formula)
            If RngDonn Is Nothing Then                ' Initialisations plage et tableaux impliqués.
               Set Wsh = CelTit.Worksheet
               Set RngDonn = Intersect(Wsh.Rows(CelTit.Row + 1).Resize(1000000 - CelTit.Row), Wsh.UsedRange)
               TSrc = RngDonn.Value
               ReDim TCbl(1 To UBound(TSrc), 1 To 14)
               End If
            GarnirColonne TCbl, L, TSrc, CelTit.Column ' Transfère les valeurs de la colonne.
            End If
         Next L
      AjouterTableau TCbl ' La fonction TableUniqueCréée renvera dans un seul les tableaux ainsi mis bout à bout.
      Set RngDonn = Nothing
      Next C
      
Rem. — Préparation du résultat.
   ReDim TSyn(1 To 5000, 1 To 14)
   L = 0
   For Each Code In Gigogne(TableUniqueCréée, 2) ' Renvoie une Collection d'éléments de type SsGr à raison d'un pour chaque Code (colonne 2).
      CEstLeDébut = True: IlFautAvancer = True
      LDéb = L + 1
      For Each Détail In Code.Co
         CEstUneSuite3ou4 = Détail(0) > 2
         If CEstLeDébut And CEstUneSuite3ou4 Then Exit For
         If CEstLeDébut Then Dsgn = Détail(3) Else Détail(3) = Dsgn
         If CEstUneSuite3ou4 Then IlFautAvancer = True
         If IlFautAvancer Then L = L + 1
         If Détail(7) = "R" Then Détail(7) = "Rupture"
         If Détail(0) = 3 Then Détail(12) = Détail(12) + Détail(14)
         For C = 1 To 13
            If Not IsEmpty(Détail(C)) And IsEmpty(TSyn(L, C)) Then TSyn(L, C) = Détail(C)
            Next C
         CEstLeDébut = False: IlFautAvancer = CEstUneSuite3ou4: Next Détail
      If L = LDéb + 1 Then
         TSyn(LDéb, 1) = TSyn(L, 1)
         For C = 11 To 13: TSyn(LDéb, C) = TSyn(L, C): Next C
         For C = 1 To 13: TSyn(L, C) = Empty: Next C
         L = L - 1
      ElseIf L > LDéb Then
         TSyn(LDéb, 11) = "=SUBTOTAL(9,OFFSET([@[Qté Cdée]],1,0," & L - LDéb & ",1))"
         TSyn(LDéb, 12) = "=SUBTOTAL(9,OFFSET([@[Qté Prép]],1,0," & L - LDéb & ",1))"
         End If
      Next Code
   With Me.ListObjects(1)
      If .ListRows.Count > L Then .ListRows(L + 1).Range.Resize(.ListRows.Count - L).Delete xlShiftUp
      Me.[A2:N5001].ClearContents
      .DataBodyRange.Resize(L, 13).Value = TSyn
      End With
   End Sub
 

Moreno076

XLDnaute Impliqué
Bonsoir.
Ok je l'ai copié dedans, il me met un message d'erreur.

1583709909737.png


Qu'apportes t-il de plus du coup?
 

Pièces jointes

  • Gigogne13Moreno076.xlsm
    147.5 KB · Affichages: 2

Dranreb

XLDnaute Barbatruc
C'est votre classeur. Ça n 'a rien à voir avec la macro. Vérifiez vos liaisons.
(Menu Données, groupe Connexions, commande Modifier les liaisons)

Remarque: Ça à l'air d'être les boutons qui ont des macros d'un autre classeur qui leur sont affectées.
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
J'ai oublié de supprimer une instruction qui ne sert plus à rien, et qui de plus supprimerait une formule mise manuellement sur la colonne N, qui sinon ne serait plus à corriger par la suite.
C'est la: Me.[A2:N5001].ClearContents tout à la fin.
Pour l'impression vous pouvez attribuer le tableau comme zone d'impression.
Demandez l'impression en noir et blanc, ça usera moins d'encre …
 

Moreno076

XLDnaute Impliqué
Pour l'impression j'avais celle là

Sub Impression()
'
' IMPRESSION Macro
'

Range("A:A").Select
Selection.EntireColumn.Hidden = True
ActiveWindow.SelectedSheets.PrintOut Copies:=3, Collate:=True, _
IgnorePrintAreas:=False
Range("A:A").Select
Selection.EntireColumn.Hidden = False
Range("A1").Select
End Sub

Car je masque la première colonne et j'ai besoin de 3 copies.

Pour l'entête :

Sub ChgFormatDate()
With ActiveSheet.PageSetup
.CenterHeader = "&""Arial,Gras""&26&K75923CSuivi des ruptures au " & Format(VBA.Now, "dddd d mmmm yyyy")
End With
End Sub

Pour la mise à jour de la dernière colonne :

Sub LivClient()

Derlg = Worksheets("Synthèse").Range("b" & Rows.Count).End(xlUp).Row
Range("N2").Formula = "=WORKDAY.INTL(RC[-1],1,11,R2C[10]:R12C[10])"
Range("N2:N" & Derlg).FillDown

End Sub

Si je l'applique ca met met une date dans les cellules vides (02/01/1900).
Lorsqu'il n y a pas de date dans M on peut mettre "Pas de date précise" à la place.

Voilà pour les mises à jour prochaines.
Je n'ai rien mis dans le fichier ci-joint, j'ai juste supprimer la ligne que vous m'avez dit.
 

Pièces jointes

  • Gigogne14Moreno076.xlsm
    146.3 KB · Affichages: 6

Dranreb

XLDnaute Barbatruc
Je n'ai jamais essayé mais il devrait être possible de définir comme zone d'impression les colones depuis la deuxième jusqu'à la dernière de tout le tableau. Ce serait mieux que de masquer et démasquer.
Non mais ne mettez plus à jour la dernière colonne. Mettez y une formule une fois pour toutes. Si elle est commune à toutes les lignes elle sera reportée automatiquement quand le tableau s'agrandira. C'est un des avantages des tableaux. En N2 :
Code:
=SI(ESTNUM([@[Date réception prévue ÉTABLISSEMENT]]);SERIE.JOUR.OUVRE.INTL([@[Date réception prévue ÉTABLISSEMENT]];1;11;X$2:X$12);"")
 
Dernière édition:

Moreno076

XLDnaute Impliqué
D'accord.

Petite question concernant le lancement du fichier.
Lorsque je fais les exportations des 4 fichiers dans le chemin commun, la date d'enregistrement ne se met pas systématiquement à jour lorsqu'elle écrase mes anciens fichiers. Je pense que le mieux au lancement du fichier c'est de n'avoir aucun onglet et de charger systématiquement les 4 fichiers avec peut-être une confirmation avant "Voulez vous lancer une nouvelle gestion?" ou de laisser les onglets mais de les écraser.

Sinon j'ai mis la formule ça fonctionne comme vous l'avez dit.
 

Pièces jointes

  • Gigogne15Moreno076.xlsm
    147 KB · Affichages: 1

Dranreb

XLDnaute Barbatruc
Dans ma version j'ai fusionné la procédure ChargementDonnées avec la Worksheet_Activate. Voici l'ensemble :
VB:
Option Explicit
Private VersementOK As Boolean
Public Sub Worksheet_Activate()
   Dim Chemin As String, RngFic As Range, TFic(), C As Long, NomFic As String, DatFic As Date, _
      NbRécents As Long, Rép As VbMsgBoxResult, WbkDon As Workbook
   Chemin = Me.[CheminDonnées].Value
   Set RngFic = Me.[TabFichiers]
   TFic = RngFic.Value
   For C = 2 To 5
      NomFic = Dir(Chemin & RngFic(1, C).Value)
      TFic(6, C) = Empty: TFic(5, C) = "(• Non trouvé •)"
      While NomFic <> ""
         DatFic = FileDateTime(Chemin & NomFic)
         If TFic(6, C) < DatFic Then
            TFic(6, C) = DatFic: TFic(5, C) = NomFic
            End If
         NomFic = Dir: Wend
      If TFic(3, C) < TFic(6, C) Then NbRécents = NbRécents + 1
      Next C
   If NbRécents Then Rép = MsgBox(IIf(NbRécents > 1, NbRécents & " fichiers plus récents ont été trouvés." & vbLf _
      & "Voulez vous les ", "Un fichier plus récent a été trouvé." & vbLf & "Voulez vous l'") & "importer ?", _
      vbYesNo, "Vérification dates fichiers") Else Rép = vbNo
   If Rép = vbYes Then
      For C = 2 To 5
         If TFic(3, C) < TFic(6, C) Then
            Set WbkDon = Workbooks.Open(Chemin & TFic(5, C))
            Select Case C
               Case 2: VerserDonnées WshRuptur, WbkDon
               Case 3: VerserDonnées WshExtRea, WbkDon
               Case 4: VerserDonnées WshRécept, WbkDon
               Case 5: VerserDonnées WshCdeCX3, WbkDon
               End Select
            WbkDon.Close SaveChanges:=False
            If VersementOK Then
               TFic(2, C) = TFic(5, C)
               TFic(3, C) = TFic(6, C)
               TFic(4, C) = Now
               End If
            End If
         Next C
      End If
   RngFic.Value = TFic
   End Sub
Sub VerserDonnées(ByVal WshCible As Worksheet, ByVal WbkSource As Workbook)
   Dim RngSource As Range
   VersementOK = False
   Set RngSource = WbkSource.Worksheets(1).UsedRange
   Application.Goto RngSource
   If MsgBox("Actuellement sélectionné :" & vbLf & """" & RngSource.Address(False, False, xlA1, True) & """." _
      & vbLf & "Ce contenu sélectionné doit-il remplacer celui de la feuille :" _
      & vbLf & """[" & ThisWorkbook.Name & "]" & WshCible.Name & """ ?", _
      vbYesNo, "VerserDonnées") = vbNo Then Exit Sub
   WshCible.Cells.ClearContents
   RngSource.Copy Destination:=WshCible.[A1]
   VersementOK = True
   End Sub
Bonne nuit.
 

Dranreb

XLDnaute Barbatruc
Bonjour.
Je me suis aperçu d'un problème. L'agrandissement du tableau n'est pas complètement automatique. Ça m'étonne. Le nouveu code de la WshSynthèse :
VB:
Option Explicit
Private Sub Worksheet_Activate()
   Dim LOtDoc As ListObject, C As Long, L As Long, RngRenv As Range, TSrc(), CelTit As Range, RngDonn As Range, _
      TSyn(), Code As SsGr, Détail, Dsgn As String, Lx As Long, Wsh As Worksheet, _
      CEstLeDébut As Boolean, IlFautAvancer As Boolean, CEstUneSuite3ou4 As Boolean
      
Rem. — Analyse de la documentation.
   Set LOtDoc = WshDoc.ListObjects("TabDoc")
   For C = 2 To 5 ' Colonnes des sources.
      Set RngRenv = LOtDoc.ListColumns(C).DataBodyRange ' Récupère la colonne des renvois aux titres.
      For L = 1 To RngRenv.Rows.Count
         If RngRenv.Rows(L).HasFormula Then ' Pour chaque cellule portant une formule :
            Set CelTit = Evaluate(RngRenv.Rows(L).Formula)
            If RngDonn Is Nothing Then                ' Initialisations plage et tableaux impliqués.
               Set Wsh = CelTit.Worksheet
               Set RngDonn = Intersect(Wsh.Rows(CelTit.Row + 1).Resize(1000000 - CelTit.Row), Wsh.UsedRange)
               TSrc = RngDonn.Value
               ReDim TCbl(1 To UBound(TSrc), 1 To 14)
               End If
            GarnirColonne TCbl, L, TSrc, CelTit.Column ' Transfère les valeurs de la colonne.
            End If
         Next L
      AjouterTableau TCbl ' La fonction TableUniqueCréée renvera dans un seul les tableaux ainsi mis bout à bout.
      Set RngDonn = Nothing
      Next C
      
Rem. — Préparation du résultat.
   ReDim TSyn(1 To 5000, 1 To 14)
   L = 0
   For Each Code In Gigogne(TableUniqueCréée, 2) ' Renvoie une Collection d'éléments de type SsGr à raison d'un pour chaque Code (colonne 2).
      CEstLeDébut = True: IlFautAvancer = True
      Lx = L + 1
      For Each Détail In Code.Co
         CEstUneSuite3ou4 = Détail(0) > 2
         If CEstLeDébut And CEstUneSuite3ou4 Then Exit For
         If CEstLeDébut Then Dsgn = Détail(3) Else Détail(3) = Dsgn
         If CEstUneSuite3ou4 Then IlFautAvancer = True
         If IlFautAvancer Then L = L + 1
         If Détail(7) = "R" Then Détail(7) = "Rupture"
         If Détail(0) = 3 Then Détail(12) = Détail(12) + Détail(14)
         For C = 1 To 13
            If Not IsEmpty(Détail(C)) And IsEmpty(TSyn(L, C)) Then TSyn(L, C) = Détail(C)
            Next C
         CEstLeDébut = False: IlFautAvancer = CEstUneSuite3ou4: Next Détail
      If L = Lx + 1 Then
         TSyn(Lx, 1) = TSyn(L, 1)
         For C = 11 To 13: TSyn(Lx, C) = TSyn(L, C): Next C
         For C = 1 To 13: TSyn(L, C) = Empty: Next C
         L = L - 1
      ElseIf L > Lx Then
         TSyn(Lx, 11) = "=SUBTOTAL(9,OFFSET([@[Qté Cdée]],1,0," & L - Lx & ",1))"
         TSyn(Lx, 12) = "=SUBTOTAL(9,OFFSET([@[Qté Prép]],1,0," & L - Lx & ",1))"
         End If
      Next Code
   With Me.ListObjects(1)
      Lx = .ListRows.Count - L
      If Lx < 0 Then
         .ListRows(.ListRows.Count).Range.Resize(-Lx).Insert xlShiftDown
      ElseIf Lx > 0 Then
         .ListRows(L + 1).Range.Resize(Lx).Delete xlShiftUp
         End If
      .DataBodyRange.Resize(L, 13).Value = TSyn
      End With
   End Sub
 

Moreno076

XLDnaute Impliqué
Bonjour,

J'ai modifié le fichier.

Pour le chargement des données il me prend pas les fichiers si les fichiers ne sont pas plus récents. J'ai essayé de supprimer la fonction sans succès. J'ai besoin que ca charge systématiquement les fichiers du chemin quelque soit la date et l heure.

Merci
 

Dranreb

XLDnaute Barbatruc
Mais pourquoi ? Ne voulez vous donc pas que le résultat soient calculé en fonction des fichiers les plus récents ???
notez que vous pourriez effacer toutes les dates pour forcer par la suite leur rechargement.
 
Dernière édition:

Discussions similaires

Réponses
9
Affichages
405

Statistiques des forums

Discussions
314 450
Messages
2 109 721
Membres
110 551
dernier inscrit
Khyolyanna