Macro to take data from a grid and add it to my calender under that persons name?

[tonywatsonhelp]

Hi Everyne,

I'll try explain this the best I can hopefully its clear.

Firstly let me say Not all cells n range will have data in them!

so, I have A Sheet Called "Calendar"

In this Sheet Column H is employees names, (Start at Row 11)
Row 10 is my dates in columns M:AHM
just standard dates from 1st Jan on (01/01/2018)

Now I have another sheet that hold the data I need to put into this calendar.
that sheet is Data3

So BB holds the start Date
BC Holds the End Date for each Job.

Then BE to BX holds the names of the employees doing this Job
There might be only one employee, there might 20 max

so I need a macro that can go Down column BB starting in row 6, if its empty then goto next row when you find a row that is not empty, that's your start date, look in same row BC and that's the end date.
then look along that row from column BE and take the names in any cells from BE to BX these are the employee names.
so each employee has their own row in

Sheet Called "Calendar"​

Column H, so find that employee find the startdate in row 10 and ADD the letters "OUT" to Every Cell form start date to end date.

hope that's clear

heres a very small example:

BB

BC

BE

BC

BD

BE

BF

BG

BH

BI

to

BX

5

start date

end date

employees names

6

12/05/2018

14/05/2018

Tony

Bob

Sara

Jon

so example 1 Tony, bob,sara and jon need "OUT" for this date

7

8

9

9/5/18

10/5/18

simon

Tony

but this time its just two names

10

some gaps will appear,

11

You can Find last row using Column G as that has data in every row!

12

4/5/18

7/5/18

BOB

13

14

<tbody>
</tbody>

H

M

n

o

p

q

r

s

t

u

v

w

x

y

z

aa

ab

ac

ad

ae

af

ag

10

1/5/18

2/5/18

3/5/18

4/5/18

5/5/18

6/5/18

7/5/18

8/5/18

9/5/18

10/5/18

11/5/18

12/5/18

13/5/18

14/5/18

15/5/18

16/5/18

17/5/18

DATES CONTINUE one day at a time until column AHM

Bob

OUT

OUT

OUT

OUT

OUT

OUT

OUT

Simon

OUT

OUT

Tony

OUT

OUT

OUT

OUT

OUT

Sara

OUT

OUT

OUT

Sue

Jo

Kim

JON

OUT

OUT

OUT

<tbody>
</tbody>

So please help if you can.

Thanks

Tony

 

[dhamstad]

Try this:
Activate Microsoft Scripting Runtime from Tools-->References
Create a Class Module - name it clsCalendar and write following code in it:

Option Explicit


Public Person As String
Public StartDate As Date
Public EndDate As Date


Then in your module - paste the following:

Option Explicit
Global Datasheet As Worksheet
Global CalendarSheet As Worksheet






Sub Main()


Set Datasheet = ThisWorkbook.Worksheets("Data3")
Set CalendarSheet = ThisWorkbook.Worksheets("Calendar")
Dim dict As Dictionary

Set dict = ReadData

PrintCalendar dict





End Sub




Function ReadData()

Dim DataRange As Range, cell As Variant
Dim FirstRow As Long, lastrow As Long, RowCounter As Long, ColumnCounter As Long
Dim dict As New Dictionary
dict.CompareMode = TextCompare
Dim oCalendar As clsCalendar

FirstRow = 6
lastrow = Datasheet.Cells(Rows.Count, 54).End(xlUp).Row
Dim Person As String
Dim CalendarID As Long


For RowCounter = FirstRow To lastrow

For ColumnCounter = 57 To 76
Person = Datasheet.Cells(RowCounter, ColumnCounter)
If Person = "" Then GoTo NextRow
CalendarID = CalendarID + 1
Set oCalendar = New clsCalendar
With oCalendar
.Person = Person
.StartDate = Datasheet.Cells(RowCounter, "BB")
.EndDate = Datasheet.Cells(RowCounter, "BC")
End With

dict.Add CalendarID, oCalendar

Next ColumnCounter
NextRow:
Next RowCounter


Set ReadData = dict

End Function


Sub PrintCalendar(dict As Dictionary)


Dim oCalendar As clsCalendar
Dim key As Variant
Dim Name As String, StartDate As Date, EndDate As Date
Dim Off As Long

Dim calendarStart As Long, calendarEnd As Long
calendarStart = 13 'Column M
calendarEnd = 897 'Column AHM

Dim EntryStart As Long, EntryEnd As Long
Dim ColumnCounter As Long

'Clear existing content
Dim rg As Range
Set rg = CalendarSheet.Range("M11").CurrentRegion
rg.Offset(1).Clear

For Each key In dict.Keys
With dict(key)
Name = .Person
StartDate = .StartDate
EndDate = .EndDate
End With

Off = GetOffset(Name)

For ColumnCounter = calendarStart To calendarEnd
If CalendarSheet.Cells(11, ColumnCounter).Value >= StartDate And _
CalendarSheet.Cells(11, ColumnCounter).Value <= EndDate Then

CalendarSheet.Cells(11, ColumnCounter).Offset(Off).Value = "OUT"

End If

Next ColumnCounter


Next key


End Sub


Function GetOffset(Name As String)


Dim HeaderRow As Long
HeaderRow = 11

Dim lastrow As Long
lastrow = CalendarSheet.Cells(Rows.Count, "H").End(xlUp).Row

Dim OffsetNumber As Long, N As String

For OffsetNumber = 1 To 100000
N = CalendarSheet.Cells(HeaderRow + OffsetNumber, "H").Value
If UCase(N) = UCase(Name) Then GoTo EndFunction
Next OffsetNumber
EndFunction:

GetOffset = OffsetNumber



End Function


Works for me in small scale