Kopiëren celinhoud en comment maandplanning naar dagplanning - op basis van dropdown

Status
Niet open voor verdere reacties.
T

Textor

Gebruiker
Lid geworden
13 sep 2016
Berichten
35
Beste VBA-leden,
Recent postte ik een vraag op het Excel gedeelte : "In Excel 2010, ik heb twaalf tabbladen aangemaakt, zijnde de twaalf maanden (Jan-Dec) van het jaar. Mijn kolommen A en B, zijnde de lijst van personeelsleden Voornaam en Naam. Op elk van die sheets staat bovenaan de dag van de maand (1 tot 31), vanaf kolom C tot AG. Zo bekom ik een rooster en per persoon staat per dag een celinhoud (vaak met comments), zoals V voor verlof of Z als ze ziek zijn, enz.
Nu wil ik op het dertiende tabblad een dagplanning opstellen voor diezelfde personeelsleden die telkens het juiste tabblad selecteert, door in de cel C1 via een dropdown menu de maand in te vullen (Jan tot Dec, de namen van de tabbladen feitelijk) en de juiste dag, door in de cel B1 een cijfer van 1 tot 31 in te vullen. Dan zou Excel automatisch die kolomgegevens moeten selecteren en kopiëren naast de juiste namen op dat dertiende tabblad, vb. vanaf cel C5 en naar beneden tot vb. C16 als ik twaalf medewerkers heb."
Plongske hielp mij met een formule fantastisch goed vooruit (INDIRECT, zie voorbeeldbestand in bijlage), maar gaf aan dat voor een specifieke wens hierbij wat VBA nodig was.
Ik zou namelijk graag ook comments in de maandplanning meenemen naar de dagplanning en die comments in de cel zelf plaatsen in kolom D Detail van de dagplanning. De identiteit van de auteur moet aanwezig zijn in de maandplanning zodat ik zie wie de comment toegevoegd heeft, maar mag niet meer zichtbaar zijn in de kolom D Detail.
Ik zou met wat gepruts volgende code en formule kunnen gebruiken, maar ik hoop dat er iemand een voorzet kan geven naar een iets meer euh... sexy manier om dat te doen.
Code: 
CommentsToCells()
    Dim rCell As Excel.Range
    Dim rData As Excel.Range
    Dim sComment As String

    ' Horizontal displacement
    Const iColOffset As Integer = 1

    ' extract comments from selected range
    If TypeName(Selection) = "Range" Then
        Set rData = Intersect(Selection, ActiveSheet.UsedRange)
        For Each rCell In rData.Cells
            On Error Resume Next
            sComment = rCell.Comment.Text
            If Len(sComment) > 0 Then
                rCell.Offset(, iColOffset).Value = sComment
                rCell.Comment.Delete
            End If
            sComment = ""
            On Error GoTo 0
        Next
    End If
End Sub
en
Code: 
=IF(ISBLANK(D5);"";RIGHT(D5;LEN(D5)-FIND("*";SUBSTITUTE(D5;":";"*";LEN(D5)-LEN(SUBSTITUTE(D5;":";""))))))

Alvast bedankt voor de aandacht die u aan mijn vraag wil besteden,Bekijk bijlage Nieuwe gecomprimeerde (gezipte) map.zip
 
In bladmodule 'dagplanning'.

Ik ben er van uitgegaan dat elk blad aanwezig zal zijn en elk blad gegevens bevat in kolom A of B (anders zal de code aangepast moeten worden).
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cl As Range
If Not Intersect(Target, Range("c1:d1")) Is Nothing Then
 Application.EnableEvents = False
  With Sheets(Range("d1").Value)
      Range("a4:d16").ClearContents
      Range("a4:a16") = .Range("b3:b15").Value
      Range("c4").Resize(Application.CountA(.Range("a3:a15"))) = .Range("b3:b15").Offset(, Range("c1").Value).Value
   For Each cl In .Columns(2).SpecialCells(2)
    If Not cl.Offset(, Range("c1").Value).Comment Is Nothing Then
        If cl.Offset(, Range("c1").Value).Comment.Text <> "" Then
         Cells(cl.Row + 1, 4) = cl.Offset(, Range("c1").Value).Comment.Text
        End If
    End If
   Next
 End With
 Application.EnableEvents = True
End If
End Sub
 
Works like a charm, behalve

Beste Harry,

ik heb de code geplakt en het werkt perfect, dank je wel, behalve dat de identiteit (gebruikersnaam) van wie de comment plaatst mee verschijnt in het veldje detail (kolom D Detail van dagplanning). In mijn voorbeeldbestand zie je de naam Textor: verschijnen.
In de sheets maandplanning zou de gebruikersnaam moeten blijven in de comment, maar in de kolom D detail in de dagplanning, eenmaal de comment in de cel terecht komt, zou er geen naam te zien mogen zijn. Is dat mogelijk? Of moet ik dat met een formule doen?
Prettige avond en bedankt voor je tijd,
 
De blauwe regel is anders dan in de vorige code.
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cl As Range
If Not Intersect(Target, Range("c1:d1")) Is Nothing Then
 Application.EnableEvents = False
  With Sheets(Range("d1").Value)
      Range("a4:d16").ClearContents
      Range("a4:a16") = .Range("b3:b15").Value
      Range("c4").Resize(Application.CountA(.Range("a3:a15"))) = .Range("b3:b15").Offset(, Range("c1").Value).Value
   For Each cl In .Columns(2).SpecialCells(2)
    If Not cl.Offset(, Range("c1").Value).Comment Is Nothing Then
        If cl.Offset(, Range("c1").Value).Comment.Text <> "" Then
[COLOR=#0000ff]         Cells(cl.Row + 1, 4) = Split(cl.Offset(, Range("c1").Value).Comment.Text, ":")(1)[/COLOR]
        End If
    End If
   Next
 End With
 Application.EnableEvents = True
End If
End Sub
 
Bijna

Beste Harry,

We zijn er bijna... na de gebruikersnaam en dubbele punt in de comment staat blijkbaar een enter? Daardoor krijg ik in het tabblad Dagplanning in de kolom D Detail eerst een witregel vooraleer de tekst zelf komt. Hoe kan ik daar vanaf geraken? Dan zou het zijn zoals ik het nat droomde...
 
Veranderen in:
Code: 
 Cells(cl.Row + 1, 4) = Split(cl.Offset(, Range("c1").Value).Comment.Text, [COLOR=#0000ff]vblf[/COLOR])(1)
 
Als ik het goed begrijp

Beste Harry,

Als ik het goed begrijp, heb je de return gebruikt als "scheidingspunt"? Dat betekent dan dat ik noch de gebruikers nog een (soft) return mogen gebruiken als we een comment invoeren? Geen probleem hoor, nu had ik afgesproken om geen dubbele punten meer te gebruiken en dan moet ik afspreken dat we geen returns meer typen in de comment.
Zie ik dat goed?
 
Doe het dan zoals onderstaand en maak geen afspraken.
Code: 
Cells(cl.Row + 1, 4) = Split(cl.Offset(, Range("c1").Value).Comment.Text, ":" & vbLf)(1)
 
Hallelujah

Harry,
Dat is 'm helemaal. En zeggen dat ik me weken de pleuris gezocht heb op internet om "iets" te vinden en jij levert me dat aan binnen een ademstoot.
Hartelijk dank, ik zal dit topic afsluiten (en mijn collega's van hun sokken blazen met mijn/jouw file).
Prettig weekend,
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan