面向對象思維拆分工資條

 測試代碼

Sub Add()
    Dim st As New SalaryTableCalss
    st.Create ActiveSheet
    st.AddTitle

End Sub

Sub Delete()
    Dim st As New SalaryTableCalss
    st.Create ActiveSheet
    st.DeleteOtherLine

End Sub

 SlaryTableClass

Private m_titleLine As Range
Private m_dataLines As New Collection
Private m_others As New Collection
Private m_empty As New Collection

Public Sub Create(ByRef sht As Worksheet)
    Dim rng As Range
    
    Set TitleLine = sht.Rows("1:1")
    
    For i = 2 To sht.UsedRange.Rows.Count
        Set rng = sht.Cells(i, 1)
        If rng.Text = "" Then
           m_empty.Add rng
        ElseIf sht.Cells(i, 1).Value <> "系統來源" Then
            Dim DataLine As New DataLineClass
            Set DataLine.DataLine = sht.Rows("" & i & ":" & i)
            m_dataLines.Add DataLine
            Set DataLine = Nothing
        Else
            Set rng = sht.Cells(i, 1)
            m_others.Add rng
            Set rng = Nothing
        End If
    Next
    
End Sub

Public Property Get TitleLine()
    TitleLine = m_titleLine
End Property

Public Property Set TitleLine(rng As Range)
   Set m_titleLine = rng
End Property


Public Sub AddTitle()
    For Each dl In m_dataLines
        Dim d As DataLineClass
        Set d = dl
        If d.DataLine.Row <> 2 Then dl.AddTitle m_titleLine
    Next
End Sub

Public Sub DeleteOtherLine()
    For i = m_others.Count To 1 Step -1
        m_others(i).EntireRow.Delete
    Next
    
    For i = m_empty.Count To 1 Step -1
        m_empty(i).EntireRow.Delete
    Next
    
    
End Sub

 DataLineClass:

Private rng As Range

Public Property Get DataLine()
   Set DataLine = rng
End Property

Public Property Set DataLine(rngData As Range)
   Set rng = rngData
End Property

Public Sub AddTitle(title As Range)
    Dim num As Integer
    num = rng.Row
    title.EntireRow.Copy
    rng.EntireRow.Insert shift:=xlDown
    rng.Offset(-1, 0).EntireRow.Insert shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
End Sub