VBA to hide rows and copy values from 1 row to another sheet.

[KyleJackMorrison]

Hello,
i have a document i use for a FOE (forecast of events). It has each colleagues details on and the days which they are away. I use merged cells for blocking out more than 1 days worth of Task/Course.

What i need is a VBA to populate a weekly register to say whos here or not. It needs to read the cell which contains todays date (Mon 28/1/19) and populate the register with what activity they are on.

It's quite difficult to explain this however attached is a copy of my document and what i would like it to do.

I understand merged cells are a pain in the *** however i have found a manual way to do it!:

Hide every column apart from monday. Copy that column and paste onto work as a table. Copy that table and paste it into the register. This is the way to make it do what i would like. Just need to automate it.

Link:
https://www.dropbox.com/s/vozn3z3uwetw3gf/Public Document.xlsx?dl=0

Any help would be appreciated.

KJM

 

[DanteAmor]

I give you the macro

Sub Button1_Click()
    Dim h1 As Worksheet, h2 As Worksheet
    Dim u2 As Long
    '
    Application.ScreenUpdating = False
    '
    Set h1 = Sheets("FOE")
    Set h2 = Sheets("REGISTER")
    '
    h2.Range("G4:T" & h2.Range("E" & Rows.Count).End(xlUp).Row).ClearContents
    u2 = h2.Range("E" & Rows.Count).End(xlUp).Row
    uc1 = h1.Cells(23, Columns.Count).End(xlToLeft).Column
    uc2 = h2.Cells(2, Columns.Count).End(xlToLeft).Column
    For i = 4 To u2
        surname = h2.Cells(i, "E").Value
        forename = h2.Cells(i, "F").Value
        Set r = h1.Columns("D")
        Set b = r.Find(surname, LookAt:=xlWhole)
        If Not b Is Nothing Then
            celda = b.Address
            Do
                'detalle
                If h1.Cells(b.Row, "E").Value = forename Then
                    For j = Columns("G").Column To uc2 Step 2
                        For k = Columns("J").Column To uc1
                            If h1.Cells(23, k).Value = h2.Cells(2, j).Value Then
                                If h1.Cells(b.Row, k).MergeCells Then
                                    activity = h1.Cells(b.Row, k).MergeArea.Cells(1, 1).Value
                                Else
                                    activity = h1.Cells(b.Row, k).Value
                                End If
                                If activity <> "" Then
                                    h2.Cells(i, j).Value = activity
                                End If
                            End If
                        Next
                    Next
                    Exit Do
                End If
                Set b = r.FindNext(b)
            Loop While Not b Is Nothing And b.Address <> celda
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "End"
End Sub

 

[KyleJackMorrison]

@DanteAmor ,

Thank you ever so much! just what i needed and here's me thinking it'll be this massive code. Outstanding!

Have a good evening!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[KyleJackMorrison]

@DanteAmor

Hello, thanks for this code. However I am wondering whether it can be adapted so its finds Todays date on the "FOE" sheet and then use todays date cells to populate this weeks register?

SO i can use this each monday and it will populate each current weeks register.

TIA