Table of employee sick leave in Excel by using VBA macro - excel

Question

I want to write code by using macro VBA which calculate the number of rows depend on the different between the leave date and to the end date of leave date , then change the row values to start from the first date of month to the end.
example:
name start_leave_date end_ leave_date
customer_1 20/3/2020 7/6/2020
customer_2 12/1/2020 15/3/2020
so the result should looks like this
name start_leave_date end_leave_date
customer_1 20/3/2020 31/3/2020
customer_1 01/4/2020 30/4/2020
customer_1 01/5/2020 31/5/2020
customer_1 01/6/2020 07/6/2020
customer_2 12/1/2020 31/1/2020
customer_2 01/2/2020 28/2/2020
customer_2 12/3/2020 31/3/2020
so there is 5 rows for customers 1 because there is different of 5 months between the start and the end of leave date
so can some one help me to know what i need to add in my code to show this output , thank you
my code and my result but it need to modify to get the output which i need
input
output
my VBA code
Private Sub CommandButton1_Click()
Dim rng As Range
Dim r As Range
Dim numberOfCopies As Integer
Dim n As Integer
Dim lastRow As Long
'Dim Lastrowa As Long
ThisWorkbook.Sheets("info").Columns("E").NumberFormat = "dd/mm/yyyy"
ThisWorkbook.Sheets("info").Columns("D").NumberFormat = "dd/mm/yyyy"
ThisWorkbook.Sheets("info").Columns("F").NumberFormat = "dd/mm/yyyy"
ThisWorkbook.Sheets("new").Columns("E").NumberFormat = "dd/mm/yyyy"
ThisWorkbook.Sheets("new").Columns("D").NumberFormat = "dd/mm/yyyy"
ThisWorkbook.Sheets("new").Columns("F").NumberFormat = "dd/mm/yyyy"
Set rng = Range("A2", Range("J1").End(xlDown))
For Each r In rng.Rows
'## Get the number of months
numberOfCopies = r.Cells(1, 11).Value
If numberOfCopies > 0 Then
'## Add to a new sheet
With Sheets("new")
'## copy the row and paste repeatedly in this loop
For n = 1 To numberOfCopies
lastRow = Sheets("new").Range("A1048576").End(xlUp).Row
r.Copy
'.Range ("A" & n)
Sheets("new").Range("A" & lastRow + 1).PasteSpecial xlPasteValues
Next
End With
End If
Next
End Sub

Answer 1

Unpivot Monthly
Adjust the values in the constants section.
If you don't want to copy the last column you can define the Source Range like this:
Dim srg As Range
With wb.Worksheets(sName).Range(sFirst).CurrentRegion
Set srg = .Resize(, .Columns.Count - 1)
End With
Use - 2 if you don't want the last two columns.
The Code
Option Explicit
Sub unpivotMonthly()
' Define Constants.
Const sName As String = "info"
Const sFirst As String = "A1"
Const dName As String = "new"
Const dFirst As String = "A1"
Const cStart As Long = 5
Const cEnd As Long = 6
' Define Workbook.
Dim wb As Workbook: Set wb = ThisWorkbook
' Define Source Range.
Dim srg As Range: Set srg = wb.Worksheets(sName).Range(sFirst).CurrentRegion
' Write values from Source Range to Data Array.
Dim Data As Variant: Data = srg.Value
Dim srCount As Long: srCount = UBound(Data, 1) ' Source Rows Count
Dim cCount As Long: cCount = UBound(Data, 2) ' Columns Count
' Define Months Array.
Dim mData As Variant: ReDim mData(2 To srCount)
Dim rrCount As Long: rrCount = 1 ' Result Array Rows Count - 1 for headers
Dim mDiff As Long ' Current Months Between First and Last (incl.)
Dim i As Long ' Data (Source) Array Rows Counter
' Calculate Result Array Rows Count and populate Months Array.
For i = 2 To srCount
mDiff = DateDiff("M", Data(i, cStart), Data(i, cEnd)) + 1
mData(i) = mDiff
rrCount = rrCount + mDiff
Next i
' Define Result Array.
Dim Result As Variant: ReDim Result(1 To rrCount, 1 To cCount)
Dim k As Long: k = 1 ' Result Array Rows Counter - 1 for headers
' Declare additional variables.
Dim j As Long ' Data and Result Array Columns Counter
Dim m As Long ' Months Counter
' Write headers.
For j = 1 To cCount
Result(1, j) = Data(1, j)
Next j
' Write 'body'.
For i = 2 To srCount
For m = 1 To mData(i)
k = k + 1
For j = 1 To cCount
Select Case j
Case cStart
If mData(i) = 1 Then
Result(k, j) = Data(i, j)
Result(k, cEnd) = Data(i, cEnd)
Else
If m = 1 Then
Result(k, j) = Data(i, j)
Result(k, cEnd) = dateLastInMonth(Data(i, j))
Else
If m = mData(i) Then
Result(k, j) = dateFirstInMonth(Data(i, cEnd))
Result(k, cEnd) = Data(i, cEnd)
Else
Result(k, j) = Result(k - 1, cEnd) + 1
Result(k, cEnd) = dateLastInMonth(Result(k, j))
End If
End If
End If
Case Is <> cEnd
Result(k, j) = Data(i, j)
End Select
Next j
Next m
Next i
' Write result.
With wb.Worksheets(dName).Range(dFirst).Resize(, cCount)
.Resize(k).Value = Result
.Resize(.Worksheet.Rows.Count - .Row - k + 1).Offset(k).ClearContents
End With
End Sub
Function dateFirstInMonth( _
ByVal d As Date) _
As Date
dateFirstInMonth = DateSerial(Year(d), Month(d), 1)
End Function
Function dateLastInMonth( _
ByVal d As Date) _
As Date
If Month(d) = 12 Then
dateLastInMonth = DateSerial(Year(d), 12, 31)
Else
dateLastInMonth = DateSerial(Year(d), Month(d) + 1, 1) - 1
End If
End Function

Answer 2

Try,
Sub test()
Dim Ws As Worksheet, toWs As Worksheet
Dim vDB, vR()
Dim sDAy As Date, eDay As Date
Dim i As Long, n As Long, r As Long
Dim j As Integer, c As Integer, k As Integer
Set Ws = Sheets(1) 'set input Sheet
Set toWs = Sheets(2) 'set ouput Sheet
vDB = Ws.Range("a1").CurrentRegion
r = UBound(vDB, 1)
ReDim vR(1 To 11, 1 To r * 20)
For i = 2 To r
sDAy = getDay(vDB(i, 5)) '<~~if Leave from is not text -> vDB(i,5)
eDay = getDay(vDB(i, 6)) '<~~if Leave to is not text -> vDB(i,6)
c = DateDiff("m", sDAy, eDay)
For j = 0 To c
n = n + 1
Select Case c
Case 0
vR(5, n) = sDAy
vR(6, n) = eDay
Case Else
If j = c Then
vR(5, n) = DateSerial(Year(sDAy), Month(sDAy) + j, 1)
vR(6, n) = eDay
ElseIf j = 0 Then
vR(5, n) = sDAy
vR(6, n) = DateSerial(Year(sDAy), Month(sDAy) + j + 1, 0)
Else
vR(5, n) = DateSerial(Year(sDAy), Month(sDAy) + j, 1)
vR(6, n) = DateSerial(Year(sDAy), Month(sDAy) + j + 1, 0)
End If
End Select
For k = 1 To 11
If k < 5 Or k > 6 Then
vR(k, n) = vDB(i, k)
If k = 4 Then
vR(k, n) = getDay(vDB(i, k)) 'if [Star work date]is not text then remove this line
End If
End If
Next k
Next j
Next i
ReDim Preserve vR(1 To 11, 1 To n)
With toWs
.Range("a1").CurrentRegion.Offset(1).ClearContents
.Range("a2").Resize(n, 11) = WorksheetFunction.Transpose(vR)
.Range("d:f").NumberFormatLocal = "dd/mm/yyyy"
End With
End Sub
Function getDay(v As Variant)
Dim vS
vS = Split(v, "/")
getDay = DateSerial(vS(2), vS(1), vS(0))
End Function