Zone impression

Bonsoir le forum,

Je souhaiterais créer une macro qui dans le fichier ci joint imprimerait :

• les lignes figées A1..AE7
• le tableau ayant la date du jour dans la colonne B.

Nous sommes samedi donc A1..AE7 puis en dessous B103..AE111

Merci à vous.

Bonjour,

A tester !...

Public Sub PrintToday()
Dim d As Integer, startRow As Long, rngPrint As Range
    d = Weekday(VBA.Date)
    If d > 1 Then
        With ActiveSheet
            .PageSetup.PrintTitleRows = "$1:$7"
            startRow = VBA.Switch(d = 2, 8, d = 3, 27, d = 4, 46, d = 5, 65, d = 6, 84, d = 7, 103)
            If d < 7 Then
                Set rngPrint = .Cells(startRow, 2).Resize(19, 21)
            Else
                Set rngPrint = .Cells(startRow, 2).Resize(9, 21)
            End If
        End With
        rngPrint.PrintOut preview:=True
    End If
End Sub

Bonjour Moreno076, Jean-Eric , le forum,

Comme j'ai passé un peu de temps dessus, voici ma proposition....(pas cool les cellules fusionnées )

Sub test()

Dim dl As Long, i As Long

 Application.ScreenUpdating = False

   With Sheets("Activité")
   dl = .Range("B" & Rows.Count).End(xlUp).Row
    For i = 8 To dl
     If .Range("B" & i).MergeArea.Columns.Count Then
      If CDate(.Range("B" & i)) = Date Then
        Rows(i).Hidden = False
      Else
        Rows(i).Hidden = True
      End If
     End If
    Next i
    .PageSetup.PrintArea = "$A$1:$AG$" & ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row + 1
    .PageSetup.Zoom = False
    .PageSetup.FitToPagesTall = 1
    .PageSetup.FitToPagesWide = 1
    .PrintPreview
    .Rows.Hidden = False
  End With
End Sub

Cordialement,

Bonjour à tous.

Je viens d'essayer en modifiant la date du jour du Pc, ça n'a pas l'air de fonctionner Xorsankukai.

Cdlt

Re,

Merci pour ton retour,

Je viens d'essayer en modifiant la date du jour du Pc, ça n'a pas l'air de fonctionner Xorsankukai.

J'aurai mieux fait de m'abstenir de répondre, , la solution de Jean-Eric répondant clairement à ta demande .

Mais je n'aime pas rester sur un échec, donc nouvelle proposition.....qui vaut ce qu'elle vaut...

J'utilise la colonne A pour masquer les lignes (récupération de la date de la colonne C: police en blanc).

Sub test()

Dim dl As Long, i As Long

 Application.ScreenUpdating = False

   With Sheets("Activité")
   dl = .Range("C" & Rows.Count).End(xlUp).Row
    For i = 8 To dl
     a = Format(Range("C" & i), "dd mmmm")
      Range("A" & i) = DateAdd("d", 1, a): Range("A" & i).Font.Color = RGB(255, 255, 255)
 '
      If Range("A" & i).Value = Date Then
        Rows(i).Hidden = False
      Else
        Rows(i).Hidden = True
      End If

    Next i
    .PageSetup.PrintArea = "$A$1:$AG$" & ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row + 1
    .PageSetup.Zoom = False
    .PageSetup.FitToPagesTall = 1
    .PageSetup.FitToPagesWide = 1
    .PrintPreview
    .Rows.Hidden = False
  End With
End Sub

Cordialement,

Ca fonctionne aussi

Je suis parti sur mon ancienne présentation plus adaptée et j'ai réadapté.

Par contre par un petit pour le msg box, je voudrais que la demande se fasse dans chaque feuille si date absente.

Actuellement ca met que si la date de la première feuille est rempli ou pas.

D'autre part si on ne rentre pas de date ca met debogage, ne peut-on pas mettre un message d'erreur plutot? merci

Re,

Désolé, je n'ai pas trop le temps cet après-midi....

Un essai sans la gestion d'erreur....

Private Sub Workbook_Open()
  Dim Rng As Range, ws As Worksheet
  Application.AskToUpdateLinks = True
  ' Semaine en lignes

  For Each ws In ThisWorkbook.Worksheets
    Set Rng = ws.[B3]
  ' Semaine en Colonnes
    If IsEmpty(Rng.Value) Then
      Rng.Value = CDate(InputBox("Veuillez rentrer la date du 1er jour de la semaine", "Ouverture " & ws.Name, Date))
    End If
  Next ws
End Sub

Cordialement,

Pas de soucis non en fait je voulais un message d'erreur mais sans débogage.

Je vais créer un nouveau sujet ce sera plis simple pour les recherches.

merci à toi

Re,

Un essai en obligeant à saisir une date....

Private Sub Workbook_Open()
  Dim Rng As Range, ws As Worksheet
  Application.AskToUpdateLinks = True
  ' Semaine en lignes
1
  For Each ws In ThisWorkbook.Worksheets
    Set Rng = ws.[B3]
  ' Semaine en Colonnes

    If IsEmpty(Rng.Value) Then
    On Error Resume Next
      Rng.Value = CDate(InputBox("Veuillez rentrer la date du 1er jour de la semaine", "Ouverture " & ws.Name, Date))
     If Rng.Value = "" Then MsgBox "Date absente en " & ws.Name: GoTo 1
    End If
  Next ws
End Sub

Cordialement,

NICKEL et en plus pour chaque feuille.

Merci beaucoup

autre version....message uniquement....

Private Sub Workbook_Open()
  Dim Rng As Range, ws As Worksheet
  Application.AskToUpdateLinks = True
  ' Semaine en lignes

  For Each ws In ThisWorkbook.Worksheets
    Set Rng = ws.[B3]
  ' Semaine en Colonnes

    If IsEmpty(Rng.Value) Then
    On Error Resume Next
      Rng.Value = CDate(InputBox("Veuillez rentrer la date du 1er jour de la semaine", "Ouverture " & ws.Name, Date))
     If Rng.Value = "" Then MsgBox "Date absente en " & ws.Name
    End If
  Next ws
End Sub

Cordialement,

Jean-Eric a écrit :

Bonjour,

A tester !...

Public Sub PrintToday()
Dim d As Integer, startRow As Long, rngPrint As Range
    d = Weekday(VBA.Date)
    If d > 1 Then
        With ActiveSheet
            .PageSetup.PrintTitleRows = "$1:$7"
            startRow = VBA.Switch(d = 2, 8, d = 3, 27, d = 4, 46, d = 5, 65, d = 6, 84, d = 7, 103)
            If d < 7 Then
                Set rngPrint = .Cells(startRow, 2).Resize(19, 21)
            Else
                Set rngPrint = .Cells(startRow, 2).Resize(9, 21)
            End If
        End With
        rngPrint.PrintOut preview:=True
    End If
End Sub

Bonjour Jean-Eric,

Les horaires ont changé du coup il ne me faut plus que le matin, j'ai essayé de changer mais ca ne fonctionne pas, j'aurais besoin de ton regard professionnel

Merci