Printen vaste kolom + variabele kolom

Status
Niet open voor verdere reacties.
Dat begint er serieus op te trekken :)

Maar je verwijst naar Sheet 1

Code: 
Set shCopy = Sheets("week 1")

Maar moet dit dan niet ActiveSheet zijn, is een jaarplanning...
Dus het weeknummer is elke week anders...
 
Laatst bewerkt door een moderator:
ja, maar bij het schrijven van de macro was dat eenvoudiger :eek:.
 
Laatst bewerkt door een moderator:
Ik heb dit proberen aan te passen naar de sheet van die week (ActiveSheet), maar lukt niet...
Wacht wel ff af :)
 
Code: 
 Set shCopy = ActiveSheet
 
Hij doet het met jaartal 2018 WEEK 1, maar als ik dit aanpas naar WEEK 4 en 2019 (links boven), doet ie niets...
 
bovenin de macro stond deze zin, anders kon hij niets vinden.
Dus die regel moet weg
Code: 
rw = Application.Match(CLng(DateSerial(2018, 1, 2)), .Rows(14), 0)    '<--- om de datum te doen kloppen !!!
Nog een extra fantasietje, als je een datum intikt in de cel A4 van je activesheet, dan zoek hij die datum en print die af.
Staat er geen geldige datum in A4, dan wordt vandaag afgeprint

Het bovenste deel van de macro wordt dus
Code: 
Sub Cow18()
    Dim rw, shCopy, shPaste
    Set shCopy = ActiveSheet
    With shCopy
        
        If IsDate(.Range("A4")) Then                                 'staat er een datum in cel A4, dan neem je die datum
            rw = Application.Match(CLng(.Range("A4").Value), .Rows(14), 0)
        Else
            rw = Application.Match(CLng(Date), .Rows(14), 0)         'anders neem je vandaag
        End If
        
        If Not IsError(rw) Then
... rest van de macro
 
In welke vorm geef ik datum dan in?
Gaat hij zoeken enkel tussen de vijf dagen van de week van de ActiveSheet? Gaat hij heel de ActiveWorkbook doorlopen (alle verschillende weken)?
 
gewoon 25/1 of 25/1/19 en ja, natuurlijk alleen in je activeSheet met deze macro.
Niets weerhoud je ervan om daar een loopje te bouwen en in alle werkbladen die datum te zoeken ... .
 
In de ActiveSheet is prima! Werkt goed :)
Alleen zou hij dan ook in de "header" de dag moeten zetten die in cel A4 staat.

Het tweede probleem wat ik nog ondervind is dat alle cellen met het woord "naam" in de vaste kolom ook steeds wit worden...
Code: 
 With shPaste
                .UsedRange.SpecialCells(4).Interior.Color = xlNone
 
Code: 
Sub Cow18()
    Dim rw, shCopy, shPaste, datum
    Set shCopy = ActiveSheet
    With ActiveSheet
        datum = IIf(IsDate(.Range("A4")), CLng(.Range("A4")), CLng(Date))    'staat er een datum in cel A4, dan neem je die datum
        rw = Application.Match(datum, .Rows(14), 0)                  'zoek datum in huidig werkblad
        If IsError(rw) Then                                          'niet gevonden
            For Each sh In ThisWorkbook.Worksheets                   'alle werkbladen afzoeken
                rw = Application.Match(datum, sh.Rows(14), 0)        'anders neem je vandaag
                If Not IsError(rw) Then Set shCopy = sh: Exit For    'gevonden in een bepaald blad, dan is het die en uit de loop treden
            Next
        End If
    End With

    If Not IsError(rw) Then
        With shCopy
            .Columns("F:ad").Hidden = True
            .Range("14:15,36:37,60:61").EntireRow.Hidden = True
            .Columns(rw).Resize(, 4).Hidden = False
            Set shPaste = Sheets.Add
            shCopy.Range("A17:D75").SpecialCells(xlCellTypeVisible).Copy
            shPaste.Range("A1").PasteSpecial Paste:=xlPasteAll       'probleempje met samengevoegde cellen !!!
            shCopy.Range("F17:AB75").SpecialCells(xlCellTypeVisible).Copy
            shPaste.Range("E1").PasteSpecial Paste:=xlPasteAll
            With shPaste
                .UsedRange.SpecialCells(4).Interior.Color = xlNone
                With .PageSetup
                    .CenterHeader = Format(datum, "long date")
                    .CenterVertically = True
                    .CenterHorizontally = True
                    .Orientation = xlPortrait
                    .PaperSize = xlPaperA4
                    .FitToPagesTall = 1
                    .FitToPagesWide = 1
                    .Zoom = False
                    .HeaderMargin = 10
                    .TopMargin = 25
                    .BottomMargin = 10
                End With
                .PrintPreview
            End With
            Application.DisplayAlerts = False
            shPaste.Delete
            Application.DisplayAlerts = True
            .UsedRange.EntireRow.Hidden = False
            .UsedRange.EntireColumn.Hidden = False
            Application.CutCopyMode = False
        End With
    End If
End Sub
 
had eigenlijk iets anders dan die 3 verwacht, maar dat zal wel weer door die samengevoegde cellen zijn, die veroorzaken altijd misverstanden
Code: 
   .UsedRange.Offset(, 3).SpecialCells(4).Interior.Color = xlNone
die datum was al mee aangepast in vorig bericht
 
Als de datum niet "bestaat" MsgBox "Datum bestaat niet" en Exit Sub.

Als ik nu een niet bestaande datum ingeef print hij ook niet vandaag af...
 
de laatste regels van je macro worden
Code: 
 Else
        MsgBox "datum, " & Format(datum, "long date") & ", niet gevonden in geen enkele werkblad"
    End If
End Sub
 
@cow

Is het effekt van

Code: 
 shCopy.Range("A17:D75").Copy

niet hetzelfde als

Code: 
 shCopy.Range("A17:D75").SpecialCells(xlCellTypeVisible).Copy

Ik krijg niet de indruk dat de vraagsteller zich ontwikkelt met behulp van jouw suggesties. Het is meer: 'maakvoormij', dan 'helpmij'.
 
Ik was nog bij in de macro aan het zetten dat sommige rijen waarvan de cellen gekleurd zijn wit moeten worden en waar iets instaat deze leeg moet worden...

De code werkt wel maar de voorwaardelijke opmaak wordt niet overruled...Dus deze cellen zijn niet onderhevig aan de macro...

bv:
Code: 
ActiveSheet.Rows("16").Cells.Interior.Color = vbWhite
 
er staan een bult foute voorwaardelijke opmaken in je tabblad "weekx", zodat ik de draad even kwijt ben.
zie anders eens hoe je rij 16 met 2 voorwaardelijke opmaken kan aansturen ipv tig aantal.

Rij 16 wordt niet meegenomen naar je hulpblad, dus weet ik niet wat je bedoelt.
 

Bijlagen

  • vw.xlsx
    299 KB · Weergaven: 32
De voorwaardelijke opmaak was/is:
Elke twee uur (bv 06-08/…) zijn er 20 uren te plannen. Als de waarde van de cel 10 of 8 is kleurt deze oranje (waarschuwing), onder de 8 rood (te weinig uren over)…
Dat was de bedoeling die erachter zat/zit...


Wat betreft rij 16, sorry ik had mijn code een beetje aangepast (van te beginnen bij rij 17, te beginnen bij rij 16), maar dit probleem stelt zich bij alle rijen waar "tellers" staan, bv rij 27 & 39 &...:


Code: 
Sub nieuw()
    Dim datum As String
    datum = InputBox("Welke dag wil je afdrukken?" & vbCrLf & "Geef datum in dag/maand", "Dagplanning", "Datum")
    If Not IsDate(datum) Then
        MsgBox "Datum is niet correct, geef in als 23/03 of 23/03/1984 !", vbCritical, "Fout!"
    Else
        With Sheets("historiek")
            .Range("A2").Value = datum
            .Range("A2").NumberFormat = "dd\/mm\/yyyy"
        End With
    End If
End Sub

Sub Cow18_2()
    Dim rw, shCopy, shPaste, datum
    Set shCopy = ActiveSheet
    With ActiveSheet
        datum = IIf(IsDate(.Range("A4")), CLng(.Range("A4")), CLng(Date))      'staat er een datum in cel A4, dan neem je die datum
        rw = Application.Match(datum, .Rows(14), 0)                            'zoek datum in huidig werkblad
        If IsError(rw) Then                                                    'niet gevonden
            For Each Sh In ThisWorkbook.Worksheets                             'alle werkbladen afzoeken
                rw = Application.Match(datum, Sh.Rows(14), 0)                  'anders neem je vandaag
                If Not IsError(rw) Then Set shCopy = Sh: Exit For              'gevonden in een bepaald blad, dan is het die en uit de loop treden
            Next
        End If
    End With

    If Not IsError(rw) Then
        With shCopy
            .Columns("F:ad").Hidden = True
            .Range("14:15,36:37,60:61").EntireRow.Hidden = True
            .Columns(rw).Resize(, 4).Hidden = False
            Set shPaste = Sheets.Add
            shCopy.Range("A16:D75").SpecialCells(xlCellTypeVisible).Copy
            shPaste.Range("A1").PasteSpecial Paste:=xlPasteAll       'probleempje met samengevoegde cellen !!!
            shCopy.Range("F16:Ac75").SpecialCells(xlCellTypeVisible).Copy
            shPaste.Range("E1").PasteSpecial Paste:=xlPasteAll
            With shPaste
                .UsedRange.Offset(, 3).SpecialCells(4).Interior.Color = xlNone
                With .PageSetup
                    .CenterHeader = Format(datum, "long date")
                    .CenterVertically = True
                    .CenterHorizontally = True
                    .Orientation = xlPortrait
                    .PaperSize = xlPaperA4
                    .FitToPagesTall = 1
                    .FitToPagesWide = 1
                    .Zoom = False
                    .HeaderMargin = 10
                    .TopMargin = 25
                    .BottomMargin = 10
                End With
                .PrintPreview
            End With
            Application.DisplayAlerts = False
            shPaste.Delete
            Application.DisplayAlerts = True
            .UsedRange.EntireRow.Hidden = False
            .UsedRange.EntireColumn.Hidden = False
            Application.CutCopyMode = False
        End With
    End If
End Sub
 
de rode regel verwijdert alle voorwaardelijke opmaken uit dat hulpblad
Code: 
 With shPaste
                .UsedRange.Offset(, 3).SpecialCells(4).Interior.Color = xlNone
               [COLOR="#FF0000"] .Cells.FormatConditions.Delete[/COLOR]
                With .PageSetup
 
Dit alles had ik voor ogen, top!

Enkel nog over het fantasietje...hoeft niet, ben enkel benieuwd...

Ipv in een cel een datum in te geven, bv een soort kalender waar enkel de huidige en volgende werkweek opstaat, die je dan moet aanklikken...
Waarbij de dagen van de huidige week die voorbij zijn niet getoond moeten worden...
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan