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

每月反转

• 调整常量部分中的值。

• 如果您不想复制最后一列，您可以像这样定义 source Range@H_262_8@：

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

  如果您不需要最后两列，请使用 - 2@H_262_8@。

@H_944_83@

代码

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),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)
                            Result(k,cEnd) = dateLasTinR_475_11845@onth(Data(i,j))
                        Else
                            If m = mData(i) Then
                                Result(k,j) = dateFirsTinR_475_11845@onth(Data(i,cEnd))
                                Result(k,cEnd)
                            Else
                                Result(k,j) = Result(k - 1,cEnd) + 1
                                Result(k,cEnd) = dateLasTinR_475_11845@onth(Result(k,j))
                            End If
                        End If
                    End If
                Case Is <> cEnd
                    Result(k,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 dateFirsTinR_475_11845@onth( _
    ByVal d As DatE) _
As Date
    dateFirsTinR_475_11845@onth = Dateserial(Year(d),Month(d),1)
End Function

Function dateLasTinR_475_11845@onth( _
    ByVal d As DatE) _
As Date
    If Month(d) = 12 Then
        dateLasTinR_475_11845@onth = Dateserial(Year(d),12,31)
    Else
        dateLasTinR_475_11845@onth = Dateserial(Year(d),Month(d) + 1,1) - 1
    End If
End Function
@H_262_8@

,

试试，

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,Month(sDAy) + j + 1,0)
                Else
                    vR(5,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
@H_262_8@