Opgelost Statusline maken in projectplanning

[KeBr]

Beste,

Ik heb over dit onderwerp al eens gepost op 25 januari 2025. Daar is geen oplossing uitgekomen. Nu ben ik zover dat ik een werkende versie heb met uitzondering van dat de lijnen niet goed getekend worden als een rij verborgen is. Het gaat dan hierbij om "Rij-1" zoals in de macro opgenomen. wat ik wil is dat de macro zoekt naar de eerst zichtbare rij boven "Rij" Het is een heel lange macro geworden. Zie ook het bijgesloten bestand. ik heb nu rij 19 t/m 21 verborgen. Rij 18 moet in dit geval "Rij-1"zijn. Met de knop boven in kun je de macro ook uitvoeren. Ik heb de macro hieronder afgekapt na scenario1 er zijn er in totaal 7 met meerdere varianten.

Private Sub BerekenEnVoegConnectorToe9_end()

    Application.EnableEvents = False

    Dim huidigeDatum As Date
    Dim berekendeDatumStart As Date
    Dim berekendeDatumRij As Date
    Dim ws As Worksheet
    Dim feestdagenWs As Worksheet
    Dim row As Long
    Dim connector As Shape
    Dim targetColumnStart As Long
    Dim targetColumnRij As Long
    Dim found As Boolean
    Dim startDatum As Date
    Dim fractie As Double
    Dim aantalDagen As Double
    Dim dagenToevoegen As Long
    Dim feestdagenRange As Range
    Dim startX As Double, startY As Double
    Dim endX As Double, endY As Double
    Dim connectorVert As Shape
    Dim connectorHor As Shape
    Dim huidigeDatumKolom As Long
    Dim LastRow As Long

    Set ws = ThisWorkbook.Sheets("Projectplanning")
    Set feestdagenWs = ThisWorkbook.Sheets("Feestdagen")

    huidigeDatum = Date
    found = False

    For huidigeDatumKolom = 1 To ws.Columns.Count
        If IsDate(ws.Cells(6, huidigeDatumKolom).Value) Then
            If ws.Cells(6, huidigeDatumKolom).Value = huidigeDatum Then
                found = True
                Exit For
            End If
        End If
    Next huidigeDatumKolom

    If Not found Then
        MsgBox "De huidige datum werd niet gevonden in rij 6."
        Application.EnableEvents = True
        Exit Sub
    End If

    For Each connector In ws.Shapes
        If connector.Name = "Status10" Then connector.Delete
    Next connector

    Set feestdagenRange = feestdagenWs.Range("B3:B126")
    LastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).row

    For row = 9 To LastRow - 1

        If Not ws.Rows(row).Hidden Then

            If ws.Cells(row - 1, "E").Value <> "" Then
                If IsDate(ws.Cells(row - 1, "E").Value) Then
                    startDatum = ws.Cells(row - 1, "E").Value
                Else
                    MsgBox "Ongeldige datum in rij " & row - 1 & " van kolom E", vbExclamation
                    Exit Sub
                End If

                fractie = ws.Cells(row - 1, "H").Value
                If ws.Cells(row - 1, "J").Value > 0 Then
                    aantalDagen = ws.Cells(row - 1, "G").Value + ws.Cells(row - 1, "J").Value
                Else
                    aantalDagen = ws.Cells(row - 1, "G").Value
                End If

                dagenToevoegen = Application.WorksheetFunction.Floor(fractie * aantalDagen, 1)
                berekendeDatumStart = Application.WorksheetFunction.WorkDay(startDatum, dagenToevoegen, feestdagenRange)
                berekendeDatumStart = Application.WorksheetFunction.Floor(berekendeDatumStart, 1)

                If berekendeDatumStart > huidigeDatum Then
                    berekendeDatumStart = huidigeDatum
                End If
            End If

            If ws.Cells(row, "E").Value <> "" Then
                If IsDate(ws.Cells(row, "E").Value) Then
                    startDatum = ws.Cells(row, "E").Value
                Else
                    MsgBox "Ongeldige datum in rij " & row & " van kolom E", vbExclamation
                    Exit Sub
                End If

                fractie = ws.Cells(row, "H").Value
                If ws.Cells(row, "J").Value > 0 Then
                    aantalDagen = ws.Cells(row, "G").Value + ws.Cells(row, "J").Value
                Else
                    aantalDagen = ws.Cells(row, "G").Value
                End If

                dagenToevoegen = Application.WorksheetFunction.Floor(fractie * aantalDagen, 1)
                berekendeDatumRij = Application.WorksheetFunction.WorkDay(startDatum, dagenToevoegen, feestdagenRange)
                berekendeDatumRij = Application.WorksheetFunction.Floor(berekendeDatumRij, 1)

                If berekendeDatumRij > huidigeDatum Then
                    berekendeDatumRij = huidigeDatum
                End If
            End If

            ' Zoek de kolom in rij 6 die overeenkomt met de berekende datum voor rij-1 (startdatum)
            found = False
            For targetColumnStart = 1 To ws.Columns.Count
                If IsDate(ws.Cells(6, targetColumnStart).Value) Then
                    If ws.Cells(6, targetColumnStart).Value = berekendeDatumStart Then
                        found = True
                        Exit For
                    End If
                End If
            Next targetColumnStart  ' Einde van de For-lus voor targetColumnStart
        
            If Not found Then
                MsgBox "De berekende datum voor rij-1 werd niet gevonden in rij 6."
                Exit Sub
            End If
            
            ' Zoek de kolom in rij 6 die overeenkomt met de berekende datum voor de huidige rij
            found = False
            For targetColumnRij = 1 To ws.Columns.Count
                If IsDate(ws.Cells(6, targetColumnRij).Value) Then
                    If ws.Cells(6, targetColumnRij).Value = berekendeDatumRij Then
                        found = True
                        Exit For
                    End If
                End If
            Next targetColumnRij  ' Einde van de For-lus voor targetColumnRij

            If Not found Then
                MsgBox "De berekende datum voor rij " & row & " werd niet gevonden in rij 6."
                Exit Sub
            End If

            ' Gebruik Select Case om te bepalen welk scenario van toepassing is
            Select Case True
                ' Scenario 1: Rij -1 voortgang 100% en rij voortgang 100% -> plaats alleen verticale connector in de huidige datum kolom
                Case ws.Cells(row - 1, "E").Value < huidigeDatum And ws.Cells(row - 1, "H").Value = 1 And ws.Cells(row, "E").Value < huidigeDatum And ws.Cells(row, "H").Value = 1
                    startX = ws.Cells(6, huidigeDatumKolom).Left + ws.Cells(6, huidigeDatumKolom).Width - 12
                    startY = ws.Cells(row - 1, huidigeDatumKolom).Top + 12
                    endY = ws.Cells(row, huidigeDatumKolom).Top + 12 ' De eindpositie van de verticale connector
                    Set connectorVert = ws.Shapes.AddConnector(msoConnectorStraight, startX, startY, startX, endY)
                    connectorVert.Line.ForeColor.RGB = RGB(255, 0, 0)
                    connectorVert.Line.Weight = 2
                    connectorVert.Name = "Status10"
                
               



 End Select
 End If
 Next row
 
  Application.EnableEvents = True
 
End Sub

 

[E v R]

Ik heb getracht jouw code zo min mogelijk te veranderen, (anders werd het herschrijven)
oa toegevoegd:

  Set rng = ws.Cells.Range("E8:E" & LastRow).SpecialCells(xlCellTypeVisible)

  ReDim x(rng.Cells.Count - 1)
  For Each cl In rng
  x(i) = cl.row
  i = i + 1
 
  Next
 
  i = 0
    For rw = LBound(x) To UBound(x) - 1
    i = i + 1

        'If Not ws.x(i)s(x(i)).Hidden Then

een array aangemaakt met de rijnummers van de zichtbare rijen (kan nog wel wat efficiënter)
en overal waar row stond x(i), row +1 x(i+1) en row -1 x(i-1) van gemaakt
tenslotte bij alle startY +1 toegevoegd aangezien anders de horizontale lijnen precies op onzichtbare rijen terechtkomen.

 

[KeBr]

Beste Eric,

Dank voor je reactie. dit is precies wat ik nodig had. werkt fantastisch

 

[KeBr]

Helaas loop ik toch nog tegen een fout aan als ik de macro kopieer naar mijn orgineel bestand.

dit stukje geeft fout: "Er zijn geen cellen gevonden" Mogelijk omdat dit stadaard verborgen kolommen zijn met formules die ander niet mogen wijzigen of zien. kan dit nog anders opgelost worden?
Met een workarround zou ik het ook kunnen doen, dan maak ik eerst de kolom zichtbaar en aan het eind van de macor verberg ik hem weer.
Set rng = ws.Cells.Range("E8:E" & LastRow).SpecialCells(xlCellTypeVisible)

 

[KeBr]

Ik heb het kunnen oplossen met dit stukje:

Dim wasHidden As Boolean

With ws
    ' Check of kolom E verborgen is
    wasHidden = .Columns("E").EntireColumn.Hidden
    
    ' Maak tijdelijk zichtbaar indien verborgen
    If wasHidden Then .Columns("E").EntireColumn.Hidden = False
    
    ' Nu de zichtbare cellen bepalen
    Set rng = .Range("E8:E" & LastRow).SpecialCells(xlCellTypeVisible)
    
    ' Kolom weer verbergen
    If wasHidden Then .Columns("E").EntireColumn.Hidden = True
End With