Problème de date dans consolidation puis cellules vides

Le 04/05/2018 à 15:11

Bonjour,

cette macro me sert a consolider des classeurs de semaine.

la consolidation marche sauf que le classeur mensuel récapitulatif affiche décembre 1895 au lieu du mois des classeurs (avril 2018) et les cellules sont vides ?

que faut il modifier pour corriger ce bug ?

je suis en calendrier 1904 au niveau des options excel

merci de vos contributions

Astil

Option Explicit
Dim ws As Worksheet
Dim NomClasseur As String
Dim NbLign As Integer
Dim DerLign As Integer
Dim DerLignConsolidation As Integer
Dim x As Integer
Sub consolider()

    Application.ScreenUpdating = False
    Application.StatusBar = " Patientez pendant le traitement des données - Consolidation des semaines"
    Application.Calculation = xlCalculationManual
    SupprContenu
    ChDir ActiveWorkbook.Path & "\Classeurs Semaine"
    NomClasseur = Dir(ActiveWorkbook.Path & "\Classeurs Semaine\*.*")
    While Len(NomClasseur) > 0
        Application.DisplayAlerts = False
        Workbooks.Open NomClasseur
        x = Worksheets.Count
        If x = 1 Then
        NbLign = ActiveSheet.UsedRange.Rows.Count
        Range("A2:O" & NbLign).Copy
        Workbooks("Regroupe Semaine.xlsm").Activate
        DerLign = ActiveSheet.UsedRange.Rows.Count + 1
        Range("A" & DerLign).Select
        ActiveSheet.Paste
        Workbooks(NomClasseur).Close
        Else
        Generer
        Workbooks(NomClasseur).Close
        End If
        NomClasseur = Dir
        Application.DisplayAlerts = True
    Wend
    DerLignConsolidation = ActiveSheet.UsedRange.Rows.Count + 2
    Application.Calculation = xlCalculationAutomatic
    'Application.ScreenUpdating = True
    Columns("A:M").AutoFit
    Range("A1").Select
    consolider_Mois
    Application.StatusBar = False
    Sheets("Modele").Activate
    Sheets("Modele").CommandButton1.Caption = "Cliquez pour consolider"
    MsgBox "Consolidation terminée ! ", vbInformation, "INFO"
      With ActiveWorkbook
        .Save
      End With
    Application.Quit
End Sub

Sub Generer()
Dim j%, Dl%, Lr%
  Application.ScreenUpdating = False

    Sheets("Feuille1").Activate
    Columns("A:M").Clear
    Range("A1").Value = "IDE"
    Range("B1").Value = "Date"
    Range("C1").Value = "Nom"
    Range("D1").Value = "Matin"
    Range("E1").Value = "Midi"
    Range("F1").Value = "Soir"
    Range("G1").Value = "Cotation Matin"
    Range("H1").Value = "IFA"
    Range("I1").Value = "Cotation Midi"
    Range("J1").Value = "IFA"
    Range("K1").Value = "Cotation Soir"
    Range("L1").Value = "IFA"
    Range("M1").Value = "Commentaire"
    Range("A1:M1").Select
    Selection.Font.Bold = True
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With

  For Each ws In Worksheets
       If VBA.LCase(ws.Name) Like "*di*" Then
  'For j = 1 To 7
    Sheets(ws.Name).Select
    Dl = Range("D" & Rows.Count).End(xlUp).Row
    Range("B8:N" & Dl).Copy
    Sheets("Feuille1").Activate
    Lr = Range("D" & Rows.Count).End(xlUp).Row + 1
    Cells(Lr, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Application.CutCopyMode = False
    End If
  Next ws

  Columns("B:B").Select
  Selection.NumberFormat = "dd-mm"
  Range("A1").CurrentRegion.Select
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
    End With
  Columns("A:M").AutoFit
  Range("N1").Value = Range("A8") & "-" & Range("B8").Text
  Range("A1").Select
  Dl = Range("C" & Rows.Count).End(xlUp).Row

  Dim Dte As Integer
   For Dte = Dl To 2 Step -1
      If Cells(Dte, 2).Value <> "" And Cells(Dte, 2).Value <> "Date" Then
        Cells(Dte, 2) = Cells(Dte, 2) + 1462
      Else
        Rows(Dte).Delete Shift:=xlUp
      End If
   Next Dte
  Enregistre
End Sub

Sub Enregistre()
Dim chemin As String, Fichier As String
chemin = ThisWorkbook.Path & "\Classeurs\"
Sheets("Feuille1").Copy
Fichier = Sheets("Feuille1").Range("N1").Text & ".xlsx"
ActiveWorkbook.SaveAs Filename:=chemin & Fichier
ActiveWorkbook.Close
End Sub

Sub consolider_Mois()
  Dim NomClasseur As String
  Dim NbLign As Integer
  Dim DerLign As Integer
  Dim DerLignConsolidation As Integer

  Application.ScreenUpdating = False
  Application.StatusBar = " Patientez pendant le traitement des données - Consolidation du mois"
    Sheets("Feuil2").Activate
    Columns("A:M").Clear
    Range("A2").Value = "IDE"
    Range("B2").Value = "Date"
    Range("C2").Value = "Nom"
    Range("D2").Value = "Matin"
    Range("E2").Value = "Midi"
    Range("F2").Value = "Soir"
    Range("G1").Value = "Matin"
    Range("G2").Value = "Cotation"
    Range("H1").Value = "IFA"
    Range("I1").Value = "Midi"
    Range("I2").Value = "Cotation"
    Range("J1").Value = "IFA"
    Range("K1").Value = "Soir"
    Range("K2").Value = "Cotation"
    Range("L1").Value = "IFA"
    Range("M1").Value = "Commentaire"

    Range("A1:M2").Select
    Selection.Font.Bold = True
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With

    ChDir ActiveWorkbook.Path & "\classeurs"
    NomClasseur = Dir(ActiveWorkbook.Path & "\classeurs\*.*")
    While Len(NomClasseur) > 0
        Application.DisplayAlerts = False
        Workbooks.Open NomClasseur
        NbLign = ActiveSheet.UsedRange.Rows.Count
        Range("A2:M" & NbLign).Copy
        Workbooks("Regroupe Semaine.xlsm").Activate
        Sheets("Feuil2").Select
        DerLign = ActiveSheet.UsedRange.Rows.Count + 1
        Range("A" & DerLign).Select
        ActiveSheet.Paste
        Workbooks(NomClasseur).Close
        NomClasseur = Dir
        Application.DisplayAlerts = True
    Wend
    DerLignConsolidation = ActiveSheet.UsedRange.Rows.Count + 2
    Application.Calculation = xlCalculationAutomatic
    'Application.ScreenUpdating = True
    Range("A1").CurrentRegion.Select
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
    End With
    Columns("A:M").AutoFit
    Range("A1").Select
    Enregistre_Mois
    Columns("A:M").Clear
End Sub
Sub Enregistre_Mois()
Dim chemin As String, Fichier As String, NomClasseur As String
chemin = ThisWorkbook.Path & "\Classeurs\"
NomClasseur = Format(Right(Range("B8") - 1462, 7), "mmmm - yyyy")
Sheets("Feuil2").Copy
Fichier = NomClasseur & ".xlsx"
ActiveWorkbook.SaveAs Filename:=chemin & Fichier
ActiveWorkbook.Close
End Sub
Sub SupprContenu()
Dim Fic As String
    Fic = Dir(ThisWorkbook.Path & "\Classeurs\*.*")
    Do While Fic <> ""
        Kill ThisWorkbook.Path & "\Classeurs\" & Fic
        Fic = Dir
    Loop
End Sub
Le 04/05/2018 à 21:48

Bonjour,

Dans le code suivant, pour renseigner la variable "NomClasseur", tu ne mentionnes pas dans quel classeur tu tentes de lire "Range("B8")".

Sub Enregistre_Mois()
Dim chemin As String, Fichier As String, NomClasseur As String
chemin = ThisWorkbook.Path & "\Classeurs\"
NomClasseur = Format(Right(Range("B8") - 1462, 7), "mmmm - yyyy")
Sheets("Feuil2").Copy
Fichier = NomClasseur & ".xlsx"
ActiveWorkbook.SaveAs Filename:=chemin & Fichier
ActiveWorkbook.Close
End Sub

Bastr

Rechercher des sujets similaires à "probleme date consolidation puis vides"