Table of employee sick leave in Excel by using VBA macro

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

1. input

2. output

3. 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