excel - 使用 VBA 宏在 Excel 中的员工病假表

Question

我想通过使用宏 VBA 编写代码，它计算行数取决于休假日期和休假日期的结束日期之间的差异，然后将行值更改为从月份的第一个日期开始到结束。
例子:

name          start_leave_date    end_ leave_date 
customer_1    20/3/2020           7/6/2020
customer_2    12/1/2020           15/3/2020

所以结果应该是这样的

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

所以客户 1 有 5 行，因为休假开始日期和结束日期之间有 5 个月的不同
所以有人可以帮我知道我需要在我的代码中添加什么来显示这个输出吗，谢谢

我的代码和我的结果，但它需要修改以获得我需要的输出

输入

输出

我的 VBA 代码

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

每月取消透视

调整常量部分中的值。

如果不想复制最后一列，可以定义 Source Range像这样:

Dim srg As Range
With wb.Worksheets(sName).Range(sFirst).CurrentRegion
    Set srg = .Resize(, .Columns.Count - 1)
End With

使用- 2如果你不想要最后两列。

代码

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