First post/question so feel free to let me know if I need to add anything.
In VBA(Excel) I'm trying to find the row where my date variable falls between the start (Column A) and end dates (Column B).
The dates are contiguous, no gaps or overlaps and are all in date format (dd/mm/yyyy) therefore, I should only get one row.
The final row has an end date of 31/12/9999
StartDate
EndDate
01/04/2022
03/04/2022
04/04/2022
02/10/2022
03/10/2022
03/10/2022
04/10/2022
21/02/2023
22/02/2023
31/12/9999
If my date variable was 03/10/2022, I would get row 3. If it was 22/09/2022 I would get row 2.
In SQL I would just do
WHERE date BETWEEN StartDate AND EndDate
How do I do this in VBA?
Sub getrow()
' fails on the if statement
Dim myrow As Integer
Dim myDate As Date
myDate = "01/05/2022"
If myDate >= Sheet9.Range("A:A").Value And myDate <= Sheet9.Range("B:B").Value Then
'i have hardcoded 99 but need it to show the row number where the date falls between column a and b
myrow = 99
Else
myrow = -1
End If
'putting it in a cell for now to see output
Sheet9.Range("c15").Value = myrow
End Sub
Something like this.
Sub BetweenDates()
Dim aCell As Range, bCell As Range
Dim Start
Dim Off
On Error GoTo ErrorHandler
Start = CDate(InputBox("Start:"))
Set aCell = Columns(1).Find(DateValue(Start), LookIn:=xlFormulas)
If aCell Is Nothing Then GoTo ErrorHandler
Off = CDate(InputBox("End:"))
Set bCell = Columns(1).Find(DateValue(Off), LookIn:=xlFormulas)
If bCell Is Nothing Then GoTo ErrorHandler
Worksheets("Sheet2").Cells.ClearContents
Rows(aCell.Row & ":" & bCell.Row).Copy Worksheets("Sheet2").Range("A1")
End
ErrorHandler:
Beep
MsgBox "Not valid Date!"
End Sub
Before:
Enter '1/1/2012' and '1/10/2012'
After:
I got it to work, there is probably a better way to do it.
Sub getrow()
Dim myrow As Integer
Dim myDate As Date
Dim rownum As Integer
myDate = #1/23/2023#
For rownum = 2 To 12
If myDate >= Cells(rownum, 1).Value And myDate <= Cells(rownum, 2).Value Then
myrow = rownum
End If
Next rownum
MsgBox myrow
End Sub
If the data is definitely as you've posted you could use Application.Match.
Sub getrow()
Dim myDate As Date
Dim myrow As Variant
myDate = #1/23/2030#
myrow = Application.Match(CDbl(myDate), Range("A2:A20"), 1)
MsgBox myrow
End Sub
Related
I have a VBA Module that is trying to get all occurrences of a date in column G in one sheet. After finding the row of the occurrence, I'm saving other values from the sheet on the same row from different columns, i.e. bldg, and room, and numPerson.
What I'm trying to do after that is to get the call a function with the date, numPerson, bldg and room as arguments. The function FillDateCapacitiesInOccupancySheet should go to a different sheet and search column B for the bldg, get that row, then look for the room on the same row and place the numPpl on the row under the correct column for the date that was given. In the following code I get an Error 91 on the Loop While statement if I remove
If FoundCell Is Nothing Then
MsgBox "No Found Cell Address", vbInformation
Exit Sub
End If
The click function works fine if I remove the call to the function FillDateCapacitiesInOccupancySheet, but otherwise I get an error. Either the FoundCell or myRange is empty but I'm not sure why or how to fix it.
Sub ConflictButton_Click()
Dim sourceColumn As Range
Dim targetColumn As Range
Dim beginningDate As String, stringDate As String, month As String, day As String, year As String
Dim dates As Date
Dim occWS As Worksheet, excepWS As Worksheet
Dim beginningDateCell As Range, addDatesCells As Range, FindDateRow As Range
Dim datesArray(1 To 7) As Date, stringDatesArray(1 To 7) As String
Dim lLoop As Long, findRowNumber As Long
Dim tempMonth As String, tempDay As String
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range
'Copy Building, Room, and Max Capacity Columns from sheet Table to sheet OccupancyByDate
Set sourceColumn = ThisWorkbook.Worksheets("Table").Columns("B:D").Rows("3:500")
Set targetColumn = ThisWorkbook.Worksheets("OccupancyByDate").Columns("B:D").Rows("3:500")
sourceColumn.Copy Destination:=targetColumn
'open FindConflictDates Form
FindConflictDatesForm.Show
'Set OccupancyByDate sheet Column E Row 2 (Column Header) to the Week Starting Date,
'get the week beginning string from what was saved from the FindConflictDatesForm
If WeekBeginningString <> "" Then
beginningDate = WeekBeginningString
WeekBeginningDate = CDate(beginningDate) ' convert String to Date
Set occWS = ThisWorkbook.Sheets("OccupancyByDate")
Set excepWS = ThisWorkbook.Sheets("Telework Exceptions")
' Fill the 7 dates into header in OccupanyByDate sheet Columns E - K row 2
Dim i As Integer
i = 1
For j = 5 To 11 ' From column E(5) to K (11)
dates = WeekBeginningDate - Weekday(WeekBeginningDate, vbUseSystemDayOfWeek) + i
occWS.Cells(2, j).Value = Format(dates, "dd-mmm-yyyy") ' write dates to OccByDate sheet
'Save dates to datesArray
datesArray(i) = dates
stringDate = CStr(dates) ' convert date to string
If Mid(stringDate, 2, 1) <> "/" Then ' 2 digit month
tempMonth = Left(stringDate, 2)
Else
tempMonth = Left(stringDate, 1) ' 1 digit month
month = GetMonthAbbreviation(tempMonth)
End If
If Left(Right(stringDate, 7), 1) <> "/" Then '2 digit day
day = Left(Right(stringDate, 7), 2)
Else
day = Left(Right(stringDate, 6), 1) ' 1 digit day
' day = Mid(stringDate, 4, 2)
End If
year = Right(stringDate, 4)
stringDatesArray(i) = day & "-" & month & "-" & year
i = i + 1 ' Add 1 to increment date of week
Next j
''''''''''''''''''''''''
' Search for dates on the TW Exception Sheet
Dim numPerson As Long, Bldg As String, Room As String, foundDate As String
numPerson = 0
For i = LBound(datesArray) To UBound(datesArray)
'Search for datesArray(i) on TW Exceptions sheet
Set myRange = excepWS.Range("G:G")
Set LastCell = myRange.Cells(myRange.Cells.count)
Set FoundCell = myRange.Find(what:=stringDatesArray(i), after:=LastCell, LookIn:=xlValues)
If Not FoundCell Is Nothing Then ' if value found in column
FirstFound = FoundCell.Address
findRowNumber = FoundCell.Row 'get row number of the found date in the column on TW Excep sheet
foundDate = FoundCell.Text 'get text value of first occurence of new date found in column
Do ' Find additional occurences of date in the sheet column
findRowNumber = FoundCell.Row
If FoundCell.Offset(0, -3).Value = 1 Then
numPerson = 1
End If
If FoundCell.Offset(0, -2).Value = 1 Then
numPerson = 1
End If
Bldg = FoundCell.Offset(0, 3).Text
Room = FoundCell.Offset(0, 4).Text
FillDateCapacitiesInOccupancySheet foundDate, numPerson, Bldg, Room 'if i remove this line I don't get an error
Set FoundCell = myRange.FindNext(FoundCell)
If FoundCell Is Nothing Then
MsgBox "No Found Cell Address", vbInformation
Exit Sub
End If
Loop While (FoundCell.Address <> FirstFound)
End If
Next i 'Get next dateArray value
End If 'End if WeekBeginningString <> ""
End Sub
Sub FillDateCapacitiesInOccupancySheet(fndDate As String, numPpl As Long, Buildg As String, Rm As String)
Dim occWS As Worksheet
Dim FndCell As Range, rng As Range
Dim myNewRange As Range, LastCell As Range
Dim foundBldg As String
Dim findRowNumber As Long, count As Long
Dim dateOffset As Integer
Dim FirstFound As String
count = 0
Set occWS = ThisWorkbook.Sheets("OccupancyByDate")
Set myNewRange = occWS.Range("B:B") ' search in building column
Set LastCell = myNewRange.Cells(myNewRange.Cells.count)
Set FndCell = myNewRange.Find(what:=Buildg, after:=LastCell, LookIn:=xlValues)
If Not FndCell Is Nothing Then ' if value found in column
FirstFound = FndCell.Address
findRowNumber = FndCell.Row 'get row number of the found building in the column on OccByDate sheet
foundBldg = FndCell.Text 'get text value of first occurence of new building found in column
Do ' Find additional occurences of date in the sheet column
findRowNumber = FndCell.Row
If FndCell.Offset(0, 1).Text = Rm Then ' if room passed into function equals room for the building
'Find the date column for the date passed into function
For j = 5 To 11 ' From column E(5) to K (11)
If occWS.Cells(2, j).Text = fndDate Then
dateOffset = j - 2
count = FndCell.Offset(0, dateOffset).Value + numPpl
' write count to cell
FndCell.Offset(0, dateOffset).Value = count
End If
Next j
End If
Set FndCell = myNewRange.FindNext(FndCell)
Loop While (FndCell.Address <> FirstFound)
End If
End Sub
Any help would be greatly appreciated.
I get an Error 91 on the Loop While statement
Here:
Set FndCell = myNewRange.FindNext(FndCell)
Loop While (FndCell.Address <> FirstFound)
If that Range.FindNext call doesn't find anything, FndCell is Nothing when the While condition gets evaluated, and that would be where error 91 is being raised; the If Not FndCell Is Nothing Then parent block means nothing as soon as FndCell is re-assigned.
You need to bail out when FndCell is Nothing. Consider using Exit Do for this:
If FndCell Is Nothing Then Exit Do
Loop While FndCell.Address <> FirstFound
Only exiting the smaller scope conveys intent better than exiting the entire procedure scope here, I find - even if all that's left to execute [for now] is an End Sub statement.
Consider declaring j and having Option Explicit at the top of the module, too!
I have a variety of calibration tests. I keep all different types and their dates in one worksheet "wsCAL"
I want to populate the userform with the most recent date of one specific type of test, which is stored in Column C in wsCAL.
In theory, I want VBA to go to wsCAL, look thru column C and find all instances of one test type, find the most recent date(or MAX) in column B of those instances, then populate my userform with that date.
I've tried using the rangeCAL = .Find() function to find all instances of a test type in column C. This part works just fine. However, the application.worksheetfunction.Max(rangeCAL) I try to use fails. I'm guessing it is because that application function only works with worksheet ranges and not Find() ones. I'm struggling with taking my rangeCAL cells, making an array, then finding the most recent date (the MAX) of those.
Private Sub UserForm_Initialize() 'Upon opening the userform
Set wb = ThisWorkbook
Set wsHOME = wb.Worksheets("Home")
Set wsCAL = wb.Worksheets("Bottle Calibrations")
Set wsC1T1 = wb.Worksheets("C1T1")
'Last Calibration Date
Label27.Caption = vbNullString
With wsCAL
Dim Cell As Range
Dim myArray As Date
Dim i As Integer
Dim rangeCAL As Range
Dim rangeDateCAL As Date
i = 0
Set rangeCAL = Range("C:C").Find(What:=tank, LookAt:=xlWhole)
If Not rangeCAL Is Nothing Then
For Each Cell In rangeCAL
myArray(i) = .Range(rangeCAL.Row, "A").Value
i = i + 1
Next
Else
MsgBox "Error: no previous Calibration dates loaded."
End If
rangeDateCAL = Application.WorksheetFunction.Max(myArray)
rangeDateCAL = Format(rangeDateCAL, "yymmdd")
End With
Label27.Caption = rangeDateCAL
I keep getting the error message
"Expected array"
as soon as I get to line:
myArray(i) = .Range(rangeCAL.Row, "B").Value
UPDATE:
Label27.Caption = vbNullString
With wsCAL
Dim Cell As Range
Dim myArray(1 To 5) As Date
Dim i As Long
Dim temp As Date
Dim rangeCAL As Range
Dim rangeDateCAL As Date
i = 1
Set rangeCAL = wsCAL.Range("C1", Range("C1").End(xlDown).Address)
For Each Cell In rangeCAL
If Cell <> "" Then
If Cell.Value = tank Then
temp = wsCAL.Cells(Cell.Row, "B").Value
myArray(i) = temp
i = i + 1
End If
End If
Next
rangeDateCAL = Application.WorksheetFunction.Max(myArray)
rangeDateCAL = Format(rangeDateCAL, "yymmdd")
End With
Label27.Caption = rangeDateCAL
I implemented this change after reading your comments. This code runs, but it fills Label27.Caption with 11/22/4613 instead of the intended 11/7/2019.
I'm assuming the date value is being altered at the MAX function step, but I'm not sure what else I can change.
For Each Cell In rangeCAL
If Cell.Text <> vbNullString Then
If Cell.Text = tank Then 'assuming tank is declared a string
If tempDate < wsCAL.Cells(Cell.Row, "B").Value Then
tempDate = wsCAL.Cells(Cell.Row, "B").Value
End If
End If
End If
Next
Label27.Caption = Format(tempDate, "yymmdd")
This is what I implemented, per SmileyFTW's suggestion. Far simpler than anticipated. Works as intended though. Thank you SmileyFTW, and the others who commented with help.
Label27.Caption = vbNullString
With wsCAL
Dim Cell As Range
Dim i As Date
Dim temp As Date
Dim rangeCAL As Range
temp = 0
Set rangeCAL = wsCAL.Range("C1", Range("C1").End(xlDown).Address)
For Each Cell In rangeCAL
If Cell <> vbNullString Then
If Cell.Value = tank Then
i = wsCAL.Cells(Cell.Row, "B").Text
If i > temp Then
temp = i
End If
End If
End If
Next
End With
Label27.Caption = temp
I'm trying to Extract Products Sales From Different Sheets depends on DATES( Between Two Dates), In the mainsheet, I have Two Columns : A for Dates; B for Sales Numbers. I'm new to VBA and trying to write code from learnt Youtube Videos, So far I can be able retrieve Only Column A values i.e, Only Dates, But I could not get the Sales values along with the Dates. I'm writing the Code Down here, Could you please check it once and let me know where and what exactly the mistake arise, your Suggestion Could helpful to me. Thank you in Advance. :)
Private Sub CommandButton1_Click()
Dim sh As Worksheet, Psh As String, x As Date, y As Date
Sheet8.Columns("A").NumberFormat = "m/d/yyyy"
Psh = Me.Shproducts ' Shproducts is Command Button Name
Set sh = Worksheets(Psh)
x = CDate(Me.TextBox1) ' Start Date
y = CDate(Me.TextBox2) ' End Date
Dim i As Long, Myrange As Range, Lastrow As Long
For i = 3 To sh.Range("F" & Rows.Count).End(xlUp).Row
If sh.Cells(i, 1) >= x And sh.Cells(i, 1) <= y Then
Sheet8.Range("A1000").End(xlUp).Offset(1, 0) = sh.Cells(i, 1)
Sheet8.Range("B1000").End(xlUp).Offset(1, 0) = sh.Cells(i, 2)
End If
Next i
End Sub
i haven't tested it, but you might want to do something like this. so this is based on your code:
Private Sub CommandButton1_Click()
Dim sh As Worksheet, Psh As String, x As Date, y As Date
Dim i As Long, Myrange As Range, Lastrow As Long
Dim destinationRange As Range, c As Range, sourceRange As Range
Dim counter As Long
Dim currentDate As Date, currentSales As Double
Sheet8.Columns("A").NumberFormat = "m/d/yyyy"
Psh = Me.Shproducts ' Shproducts is Command Button Name
Set sh = Worksheets(Psh)
x = CDate(Me.TextBox1) ' Start Date
y = CDate(Me.TextBox2) ' End Date
Set destinationRange = Sheet8.Range("A100000").End(xlUp).Offset(1, 0)
Set sourceRange = Range(sh.Range("F3"), sh.Range("F3").End(xlDown))
For Each c In sourceRange
currentDate = c.Value
currentSales = c.Offset(0, 1).Value
If currentDate >= x And currentDate <= y Then
destinationRange.Offset(counter, 0).Value = currentDate
destinationRange.Offset(counter, 1).Value = currentSales
counter = counter + 1
End If
Next i
End Sub
I know "dd.mm.yyyy" is not formatted as date within Excel, and this conversion part is what is getting to me. I have "31.3.2019" within .cell("C5") and want it to convert within the same cell (replace it) with a new formatting of "3/31/2019". I keep on getting an 'out of range' error and I am not sure where my mistake is.
Below is what I have tried:
Sub DivestitureTemplate_ChangeDateFormat()
Application.ScreenUpdating = False
Dim rng As Range
Dim str() As String
Set rng = Range("C5:C3000")
With Worksheets("Divestiture Template")
For Each rng In Selection
str = Split(rng.Value, ".")
rng.Value = DateSerial(2000 + str(4), str(2), str(0))
Next rng
Selection.NumberFormat = "mm/dd/yyyy"
Application.ScreenUpdating = True
End With
End Sub
Change format of ("C5:C3000") from 31.3.2019 to 3/31/2019 -- it can be continuous, but starting at "C5" as this is an automated report and this is below a specified header. I think I have been looking at this, scripting all day and loosing my head over this for no reason.
To get real dates in the column, try:
Sub DivestitureTemplate_ChangeDateFormat()
Dim cell As Range, rng As Range, d As Date
Set rng = Worksheets("Divestiture Template").Range("C5:C3000")
For Each cell In rng
With cell
arr = Split(.Text, ".")
.Value = DateSerial(arr(2), arr(1), arr(0))
.NumberFormat = "m/dd/yyyy"
End With
Next cell
End Sub
EDIT#1:
Sub DivestitureTemplate_ChangeDateFormat()
Dim cell As Range, rng As Range, d As Date
Dim arr
Set rng = Worksheets("Divestiture Template").Range("C5:C3000")
For Each cell In rng
With cell
arr = Split(.Text, ".")
.Value = DateSerial(arr(2), arr(1), arr(0))
.NumberFormat = "m/dd/yyyy"
End With
Next cell
End Sub
First I'm open to do this with an other angle.
I want to count the total hours of work hours estimated, see sheet2. In another sub I've calculated the total work hours (timer tot) with worksheetfunction.sum and timer FRJ/HET with worksheetfunction.sumif. This code doesn't consider overlapping days which means if the dates intersect each other it will calculate 8*2(3,4,5...) (8 hours is average workday in Norway) instead of 8 hours per workday. This will mess up the total amount of time estimated and posibly we will estimate more hours per day than 24 hours :D
I've started this code underneath which I will use to substract the total amount of time and total amout for FRJ and HET.
Code:
Sub Overlapping_WorkDays()
Dim rng_FRJ_HET As Range
Dim cell_name As Range
Dim startDateRng As Range
Dim endDateRng As Range
Set rng_FRJ_HET = Sheet1.Range("A8", Sheet1.Range("A8").End(xlDown))
Set startDateRng = Sheet1.Range("D8", Sheet1.Range("D8").End(xlDown))
Set endDateRng = Sheet1.Range("E8", Sheet1.Range("E8").End(xlDown))
For Each cell_name In rng_FRJ_HET
If cell_name = "FRJ" Then
'Count Overlapping networkdays for FRJ
Elseif cell_name = "HET" Then
'Count Overlapping networkdays for HET
End If
Next cell_name
End Sub
Sheet1 screenshot
Sheet2 screenshot
All you need to do is loop through all the date ranges and count them if they haven't already been counted. A Dictionary from the Microsoft Scripting Runtime is well suited for this (you'll need to add a reference in Tools->References).
Function TotalWorkDays(Optional category As String = vbNullString) As Long
Dim lastRow As Long
With Sheet1
lastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
Dim usedDates As Scripting.Dictionary
Set usedDates = New Scripting.Dictionary
Dim r As Long
'Loop through each row with date ranges.
For r = 8 To lastRow
Dim day As Long
'Loop through each day.
For day = .Cells(r, 4).Value To .Cells(r, 5).Value
'Check to see if the day is already in the Dictionary
'and doesn't fall on a weekend.
If Not usedDates.Exists(day) And Weekday(day, vbMonday) < 6 _
And (.Cells(r, 1).Value = category Or category = vbNullString) Then
'Haven't encountered the day yet, so add it.
usedDates.Add day, vbNull
End If
Next day
Next
End With
'Return the count of unique days.
TotalWorkDays = usedDates.Count
End Function
Note that this will work for any arbitrary category found in column 1, or all categories combined if it isn't passed an argument. Sample usage:
Sub Usage()
Debug.Print TotalWorkDays("HET") 'Sample data prints 55
Debug.Print TotalWorkDays("FRJ") 'Sample data prints 69
Debug.Print TotalWorkDays 'Sample data prints 69
End Sub
You can convert this to late bound (and skip adding the reference) by replacing these two lines...
Dim usedDates As Scripting.Dictionary
Set usedDates = New Scripting.Dictionary
...with:
Dim usedDates As Object
Set usedDates = CreateObject("Scripting.Dictionary")
I think if I were doing this, I'd use the Collection object, as it'd save converting names and dates to index id's.
You could create a main collection of names and, for each name, a sub collection of dates whose key is Excel's date serial number. This would make it easy to store the 'used days' and you could either acquire the total day count by using the .Count property or loop through the collection to aggregate a specific Oppgave.
The code would be straight forward as shown below. You could just put this in a module:
Option Explicit
Private mNames As Collection
Public Sub RunMe()
ReadValues
'Get the total days count
Debug.Print GetDayCount("FRJ")
'Or get the days count for one Oppgave
Debug.Print GetDayCount("FRJ", "Malfil tegning form")
End Sub
Private Sub ReadValues()
Dim v As Variant
Dim r As Long, d As Long
Dim item As Variant
Dim dates As Collection
With Sheet1
v = .Range(.Cells(8, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 5).Value2
End With
Set mNames = New Collection
For r = 1 To UBound(v, 1)
'Acquire the dates collection for relevant name
Set dates = Nothing: On Error Resume Next
Set dates = mNames(CStr(v(r, 1))): On Error GoTo 0
'Create a new dates collection if it's a new name
If dates Is Nothing Then
Set dates = New Collection
mNames.Add dates, CStr(v(r, 1))
End If
'Add new dates to the collection
For d = v(r, 4) To v(r, 5)
On Error Resume Next
dates.Add v(r, 2), CStr(d)
On Error GoTo 0
Next
Next
End Sub
Private Function GetDayCount(namv As String, Optional oppgave As String) As Long
Dim dates As Collection
Dim v As Variant
Set dates = mNames(namv)
If oppgave = vbNullString Then
GetDayCount = dates.Count
Else
For Each v In dates
If v = oppgave Then GetDayCount = GetDayCount + 1
Next
End If
End Function
Dictionary approach should be the fastest.
But if your data are not that big you may want to adopt a "string" approach like follows
Function CountWorkingDays(key As String) As Long
Dim cell As Range
Dim iDate As Date
Dim workDates As String
On Error GoTo ExitSub
Application.EnableEvents = False
With Sheet1
With .Range("E7", .Cells(.Rows.Count, "A").End(xlUp))
.AutoFilter field:=1, Criteria1:=key
For Each cell In Intersect(.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible), .Columns(1))
For iDate = cell.Offset(, 3) To cell.Offset(, 4)
If Weekday(iDate, vbMonday) < 6 Then
If InStr(workDates, cell.value & iDate) <= 0 Then workDates = workDates & cell.value & iDate
End If
Next iDate
Next cell
End With
End With
CountWorkingDays = UBound(Split(workDates, key))
ExitSub:
Sheet1.AutoFilterMode = False
Application.EnableEvents = True
End Function
that you can use in your code as follows
sht2.Cells(2, 7) = CountWorkingDays("FRJ")
sht2.Cells(2, 8) = CountWorkingDays("HET")
As far as I know there is no direct formula to get overlap dates. My approach will be different from yours.
For each unique value in rng_FRJ_HET (i.e. only FRJ and HET as per e.g.)
Create an array with first date and last date
Mark array index with 1 for each date in range start and end date
Sum the array to get actual number of days
Next
So if the dates are repeated still they will mark as 1 in the array for that date.
=====================Added the code=== This will do for any number of names.
Option Explicit
Dim NameList() As String
Sub Overlapping_WorkDays()
Dim rng_FRJ_HET As Range
Dim cell_name As Range
Dim startDateRng As Range
Dim endDateRng As Range
Dim uniqueNames As Range
Dim stDate As Variant
Dim edDate As Variant
Dim Dates() As Integer
Set rng_FRJ_HET = Sheet1.Range("A8", Sheet1.Range("A8").End(xlDown))
Set startDateRng = Sheet1.Range("D8", Sheet1.Range("D8").End(xlDown))
Set endDateRng = Sheet1.Range("E8", Sheet1.Range("E8").End(xlDown))
stDate = Application.WorksheetFunction.Min(startDateRng)
edDate = Application.WorksheetFunction.Max(endDateRng)
ReDim NameList(0)
NameList(0) = ""
For Each cell_name In rng_FRJ_HET
If IsNewName(cell_name) Then
ReDim Dates(stDate To edDate + 1)
MsgBox cell_name & " worked for days : " & CStr(GetDays(cell_name, Dates))
End If
Next cell_name
End Sub
Private Function GetDays(ByVal searchName As String, ByRef Dates() As Integer) As Integer
Dim dt As Variant
Dim value As String
Dim rowIndex As Integer
Const COL_NAME = 1
Const COL_STDATE = 4
Const COL_EDDATE = 5
Const ROW_START = 8
Const ROW_END = 19
With Sheet1
For rowIndex = ROW_START To ROW_END
If searchName = .Cells(rowIndex, COL_NAME) Then
For dt = .Cells(rowIndex, COL_STDATE).value To .Cells(rowIndex, COL_EDDATE).value
Dates(CLng(dt)) = 1
Next
End If
Next
End With
GetDays = WorksheetFunction.Sum(Dates)
End Function
Private Function IsNewName(ByVal searchName As String) As Boolean
Dim index As Integer
For index = 0 To UBound(NameList)
If NameList(index) = searchName Then
IsNewName = False
Exit Function
End If
Next
ReDim Preserve NameList(0 To index)
NameList(index) = searchName
IsNewName = True
End Function