VBA Code to compare single column date on worksheet with 2 column start and end dates, copy select information horizontally, to empty cells.

[GAdams106]

Hello,

I'm trying to work assignments based off of requests for work. i have some VBA Experience, but everything I've tried is falling to pieces, and i wanted to see if i could get some help.
I gathered all time off requests for a timeframe (April 1 - Sept 30) in a forms and exported it to a worksheet. so it's : Name, 1st choice start, 1st choice end, BLANK, 2nd choice start, 2nd end, etc all the way to 5th choice.
On the list worksheet. i have dates listed vertically from April 1 all the way to sept 30. what i have been trying to do, is have VBA check the date in list (example: 04/01/2022) and compare it to the date ranges in all the requests on master. If a person requested time off for that day (say 04/01/-04/07) then i want it to list their last name, first name, id # (on master, G: ID # ,H: last name, I: First name) in one cell on the list worksheet row with the date. Then the next person, then the next, so that i end up with a horizontal list of every person who requested to be off on that particular day.
Examples are below. I have tried implementing multiple different codes from the forums, and none of them are getting me anywhere, so I'm absolutely up to starting from scratch.

End goal, is to have 5 buttons on the list page. 1 for each choice. 1st choice populates in 1 color, i compare the number of personnel authorized to be off that day to how many requested. If there's room for more people, press second choice, and it populates more in a different color. continuing horizontally.

I'm trying to figure this out in the macro recorder, but if anyone could help, i would truly appreciate it.

Mini Sheet Example-No PII.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	ID #	Last Name:	First Name:	1st Choice Vacation Beginning Date:	1st Choice Vacation End Date:	2nd Choice Vacation Beginning Date:	2nd Choice Vacation End Date:	3rd Choice Vacation Beginning Date:	3rd Choice Vacation End Date:	4th Choice Vacation Beginning Date:	4th Choice Vacation End Date:	5th Choice Vacation Beginning Date:	5th Choice Vacation End Date:
2	1	SMITH	JOHN	4/17/2022	5/1/2022	7/17/2022	7/24/2022	6/19/2022	6/26/2022	7/3/2022	7/10/2022	9/4/2022	9/11/2022
3	2	JACKSON	MICHAEL	7/2/2022	7/8/2022	5/25/2022	6/1/2022	4/13/2022	4/20/2022	9/1/2022	9/7/2022	6/15/2022	6/22/2022
4	3	JOHNSON	PAUL	4/22/2022	5/2/2022	4/1/2022	4/11/2022	7/24/2022	8/1/2022	6/10/2022	6/17/2022	9/16/2022	9/23/2022
5	4	POWERS	AUSTIN	7/11/2022	7/18/2022	9/19/2022	9/26/2022	7/18/2022	7/25/2022
6	5	DIGGLER	DIRK	4/13/2022	4/19/2022	6/21/2022	7/6/2022	7/12/2022	7/26/2022	8/7/2022	8/14/2022	9/7/2022	9/14/2022
7
8
9
10
11
12
13
14
15
16
17
MASTER

Mini Sheet Example-No PII.xlsm
	A	B	C	D	E	F	G	H	I
1
2	People Off:	Total Personnel: (337) 50.55 Is 15%	DATE		FIRST CHOICE (WILL BE A BUTTON)	SECOND CHOICE (WILL BE A BUTTON)	THIRD CHOICE (WILL BE A BUTTON)	FOURTH CHOICE (WILL BE A BUTTON)	FIFTH CHOICE (WILL BE A BUTTON)
3	2	4.0%	4/1/2022		Smith, John ID1	Johnson, Paul, ID 3
4			4/2/2022		Johnson, Paul, ID 3	Diggler, Dirk ID5	Powers, Austin ID 4
5			4/3/2022		Jackson, Michael ID 4
6			4/4/2022
7			4/5/2022		Johnson, Paul, ID 3	Diggler, Dirk ID5	Powers, Austin ID 4	Smith, John ID1
8			4/6/2022		Jackson, Michael ID 4	Johnson, Paul, ID 3	Diggler, Dirk ID5	Powers, Austin ID 4
9			4/7/2022
10			4/8/2022
11			4/9/2022
12			4/10/2022
13			4/11/2022
14			4/12/2022
15			4/13/2022
16			4/14/2022
17			4/15/2022
18			4/16/2022
19			4/17/2022
20			4/18/2022
List

Cell Formulas
Range	Formula
B2	B2	=" Total Personnel: (337) " & 15%*(337) & " Is 15%"
A3	A3	=SUMPRODUCT((D3:AS3<>"")*1)
B3	B3	=A3/50.55

Mini Sheet Example-No PII.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V
1	ID	NAME		1st	END	Granted		2nd	End	Granted		3rd	End	Granted		4th	End	Granted		5th	End	Granted
2	1/1/1900	SMITH	JOHN	4/17/2022	5/1/2022	YES		7/17/2022	7/24/2022	YES		6/19/2022	6/26/2022	NO		7/3/2022	7/10/2022			9/4/2022	9/11/2022
3	1/2/1900	JACKSON	MICHAEL	7/2/2022	7/8/2022	YES		5/25/2022	6/1/2022	NO		4/13/2022	4/20/2022	NO		9/1/2022	9/7/2022			6/15/2022	6/22/2022
4	1/3/1900	JOHNSON	PAUL	4/22/2022	5/2/2022	YES		4/1/2022	4/11/2022	NO		7/24/2022	8/1/2022	NO		6/10/2022	6/17/2022			9/16/2022	9/23/2022
5	1/4/1900	POWERS	AUSTIN	7/11/2022	7/18/2022	YES		9/19/2022	9/26/2022	YES		7/18/2022	7/25/2022	NO
6	1/5/1900	DIGGLER	DIRK	4/13/2022	4/19/2022	YES		6/21/2022	7/6/2022	NO		7/12/2022	7/26/2022	NO		8/7/2022	8/14/2022			9/7/2022	9/14/2022
Results

 

[GAdams106]

So,
This is where i've gotten to so far, i've pieced together a few different codes and some macro work and i'm stuck on what i "believe" to be the final part:

Sub Fix_()
Dim startdate As Date, enddate As Date
Dim rng As Range, destRow As Long
Dim shtSrc As Worksheet, shtDest As Worksheet
Dim c As Range
Dim ws As Worksheet


    Set shtSrc = Sheets("List")
    Set shtDest = Sheets("Master")
    destRow = 3 'start copying to this row

    startdate = CDate(shtDest.Cells("D").End(xlDown))
    enddate = CDate(shtDest.Cells("E").End(xlDown))

    
    Set rng = Application.Intersect(shtSrc.Range("C"), shtSrc.UsedRange)

    For Each c In rng.Cells
        If c.Value >= startdate And c.Value <= enddate Then
    startdate.Offset(0, -1).Copy
    shtSrc.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteFormulas


            destRow = destRow + 1

        End If
    Next

End Sub

In pieces everything works, however now, i can't get the code to accept the startdate.offset(0, -1).copy.
i need it to copy the date . Anyone have any ideas?


@Fluff 90% of what i know in VBA has come from your posts, was curious if you had any ideas?

 

[GAdams106]

Okay Folks,
Not gonna lie, feeling pretty great as a 1 man army, but i'm so close! scratched everything, got to here. everything seems to be lining up. but i'm still not getting my pasted data. any ideas?

Sub CopyDataUsingDateRange()

    Application.ScreenUpdating = False

    Dim wsData As Worksheet, wsDate As Worksheet
    Dim dSDate As Date, dEDate As Date
    Dim LastRow As Long
    Dim rCell As Range
    Dim Cel As Range
        
    'set the worksheet objects
    Set wsData = ThisWorkbook.Sheets("Master")
    Set wsDate = ThisWorkbook.Sheets("List")
    

    'required variables
    dSData = wsData.Range("D2").End(xlUp).Value
    dEData = wsData.Range("E2").End(xlUp).Value
    

   With Sheets("Trial")
   LastRow = Range("C3").End(xlDown).Row
   Set rCell = Range("C3" & LastRow)
    For Each Cel In rCell
        If IsDate(Cel) Then
                With wsData 
                If Cel >= dSData And rCel <= dEData Then
                    wsData.Cells.Offset(, -5).Value.Copy
                    wsDate.Cells(, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteFormulas
                    Application.CutCopyMode = False
                End If
                End With
        End If
       
    Next Cel
   End With
            
   Application.ScreenUpdating = True
   
End Sub

 

[GAdams106]

I'm really struggling at the moment. I am running through the debugger, and i can't get it to paste. would seriously love some help because i know it's something simple.

Everything i've been trying to do refuses to let me paste to the next available column. i keeeeeep trying. i just need it to paste on the row that the ChkDate cell is currently on, in the next available column. i'm going to go do this manually for now, since i have a deadline coming up.

Sub CopyDataUsingDateRange()

Application.ScreenUpdating = False

Dim sd As Date
Dim ed As Date

Dim asd As Date
Dim ChkDate As Range '<----Range
Dim Cell_Range As Range
Dim Cell As Range
Dim DateRange As Range
Dim LastRow As Long
Dim LastName As Long
Dim NameRange As Range
Dim EmptyColumn As Long


'On Error GoTo FML

LastName = Cells(Rows.Count, "B").End(xlUp).Row
LastRow = Cells(Rows.Count, 3).End(xlUp).Row
DateRow = Cells(Rows.Count, "G").End(xlUp).Row
Set DateRange = ThisWorkbook.Worksheets("Agent List").Range("G2:G" & DateRow)
Set Cell_Range = ThisWorkbook.Worksheets("Trial").Range("c2:C" & LastRow)
Set NameRange = ThisWorkbook.Worksheets("Agent List").Range("B2:B" & LastName)
EmptyColumn = Cells(, Columns.Count).End(xlToLeft).Column
Dim X as String

With ThisWorkbook.Worksheets("Agent List")
Do While Not NameRange Is Nothing
sd = 0
ed = 0

For Each Cell In DateRange
If IsDate(Cell) Then
sd = Cell.Value
ed = Cell.Offset(0, 1).Value
X = Cell.Offset(0, -5).Value
For Each ChkDate In Cell_Range
asd = ChkDate.Value
If sd <= asd And ed >= asd Then
'INSERT SOME KIND OF PASTE THAT ACTUALLY WORKS!!!
End If
'Application.CutCopyMode = True
Next ChkDate
End If
Next Cell
Loop
'End If
'Next cell
End With
Exit Sub
FML:
'MsgBox Err.Description

Application.ScreenUpdating = True
End Sub

 

[GAdams106]

SOLVED IT!
i did not stay at work until 11pm until i figured this out... :D
it's not perfect and still needs some refinement. But its working! it let me do everything i needed and after i was done writing it it took me less than an hour to finish up :D. i truly hope this helps somebody else :D

Option Explicit
'Option Explicit is very helpful because it will throw an error on compile if
'you have undefined variables floating around in your project.

Sub LoopRangeFifth() ' i made 5 buttons, so this one was for the 5th. each button has different offsets
Application.ScreenUpdating = False 'Faster runtime

'On Error Resume Next

Dim iWS As Worksheet: Set iWS = ThisWorkbook.Sheets("First")
Dim oWS As Worksheet: Set oWS = ThisWorkbook.Sheets("List")
'output is the worksheet that has data you want to pull from, input is the sheet you're going to be 
'putting data into. i know.. leave me alone, it works.
Dim inputRange As Range: Set inputRange = iWS.Range("c2", iWS.Range("c2").End(xlDown))
Dim outputRange As Range: Set outputRange = oWS.Range("b2", oWS.Range("b2").End(xlDown))
Dim MyCell As Range

Dim startDate As Date
Dim endDate As Date
            
Dim iCell As Range, oCell As Range
Dim i As Integer
i = 1
'icell is going to be for iWS, i is going to be to move cells
For Each oCell In outputRange 'for each name in the list
If Not IsEmpty(oCell) Then 
    If IsDate(oCell.Offset(0, 14)) Then ' if the start date across from the name is a date (not a empty cell)
        startDate = oCell.Offset(0, 14).Value 'set that offset as start date
            endDate = oCell.Offset(0, 15).Value 
        For Each iCell In inputRange 'nested loop. with that start date, start comparing against the new list
            If iCell.Value >= startDate And iCell.Value <= endDate Then  'if compared date is in range
            oCell.Copy 'copy the name of the person with those dates
            iCell.Select 'get activecell, for some reason, paste special errored after 2 ocells
            
Line41:     If IsEmpty(ActiveCell.Offset(0, 1 + i)) Then   'so now for the pasting, offset from active cell (to the right, and add a counter
            GoTo FinishHim 'pasting option
            
            Else
            GoTo ThisisBull 'increase integer option
            End If
            Else
            GoTo Line47
            End If
Line47:     Next iCell
    Else
    GoTo Line49
    End If
Else: GoTo Line49
End If
Line49: Next oCell

Exit Sub
FinishHim:
            ActiveCell.Offset(0, 1 + i).PasteSpecial xlValues, Transpose:=False 'paste in that offset, reset iteger, go to next date to compare
            i = 1
            GoTo Line47
ThisisBull:
    i = i + 1 ' increase integer, check if new offset is empty
    GoTo Line41
' i still need to add error catching, see if i can't speed this up any, and put in some safeguards, but it worked!        
Application.ScreenUpdating = True 
End Sub