Option Explicit
'ファイル分割クラス
'プロパティは、メンバー以外アクセスできない

'プロパティの実体
Private mobjWB As Workbook      'ワークブック
Private mobjWS() As Worksheet   'ワークシート
Private mstrDir As String       'カレントディレクトリ値
Private mstrNewName As String   '新しいファイル名
Private mintCurrent As Integer  '進行年度の年
Private mintStart As Integer    'データの最初の年
Private mlngEndRow As Long      '削除対象最後のセルの行番号
Private mintSagaku As Integer   '差額

'ファイル分割メソッド
Public Sub StartDivision()

    Call GetCurrentDate
    Call GetStartDate
    Call CalcYear
    
    If mintSagaku < 3 Then MsgBox "経過年数が" & mintSagaku & "年です。" & vbCrLf & "ファイルを分割する必要がありません。", 64 + 0, "給与計算システム": Exit Sub
    
    Call GetRow
    Call DeleteRow
    Call DeleteSyain 'exit 2004/06/09
    Call SetNewName
    
End Sub

'進行年度の取得
Private Sub GetCurrentDate()

    mintCurrent = Year(CDate(mobjWS(0).Cells(3, 1).Value))
    
End Sub

'データの最初の日付の取得
Private Sub GetStartDate()

    mintStart = Year(CDate(mobjWS(1).Cells(1, 4).Value))
    
End Sub

'経過年の算出
Private Sub CalcYear()

    mintSagaku = mintCurrent - mintStart
    
End Sub

'対象レコードの検出
Private Sub GetRow()

    Dim i As Long       'カウンター
    
    i = 1
    
    While mintCurrent - Year(CDate(mobjWS(1).Cells(i, 4).Value)) > 2
        mlngEndRow = i
        i = i + 1
    Wend
    
End Sub

'対象レコードの削除
Private Sub DeleteRow()

    mobjWS(1).Activate
    Range(Cells(1, 1), Cells(mlngEndRow, 25)).Delete
    
End Sub

'退職社員削除-----edit 2004/06/09
Private Sub DeleteSyain()

    Dim r As Long   '最終行
    Dim i As Long   'カウンタ
    Dim j As Long   'カウンタ
    Dim id As Long  '社員ID
    
    r = mobjWS(2).Cells(65536, 1).End(xlUp).Row
    
    For i = r To 1 Step -1
        If mobjWS(2).Cells(i, 6).Value > 0 Then
            If mintCurrent - Year(CDate(mobjWS(2).Cells(i, 9).Value)) > 0 Then
                id = CLng(Cells(i, 1).Value)
                mobjWS(3).Activate
                j = Cells(65536, 1).End(xlUp).Row
                Cells(j, 1).Activate
                While ActiveCell.Value <> ""
                    If id = CLng(ActiveCell.Value) Then ActiveCell.EntireRow.Delete
                    If j > 0 Then j = j - 1
                    Cells(j, 1).Activate
                Wend
                mobjWS(2).Activate
                Range(Cells(i, 1), Cells(i, 29)).Delete xlShiftUp
            End If
        End If
    Next
    
End Sub

'名を付けて保存
Private Sub SetNewName()
    
    Dim vntName As Variant          'エラー時のファイル名
    Dim strTempName As String       '拡張子なしファイル名
    Dim intPos As Integer           '検索文字列の有無
    Dim intMsg As Integer           'メッセージの戻り値
    Dim lngFileLen As Long          'ファイルの長さ
    Const strMoji As String = "NO"  '付け加える文字列
    
    
    lngFileLen = Len(gstrName)
    strTempName = Mid$(gstrName, 1, lngFileLen - 4)
    intPos = InStr(1, gstrName, strMoji)
    
    If intPos = 0 Then mstrNewName = strTempName & strMoji & CStr(mintCurrent)
    If lngFileLen > 1 Then
        If intPos <> 0 Then mstrNewName = Mid$(strTempName, 1, intPos + 1) & CStr(mintCurrent)
    Else
        If intPos <> 0 Then mstrNewName = Mid$(strTempName, 1, intPos) & CStr(mintCurrent)
    End If
    
    '同じファイル名の検査
    If Dir(CStr(mstrNewName & ".xls")) <> "" Then GoTo ErrorPrc

    mobjWB.SaveAs mstrNewName
    gstrName = mstrNewName & ".xls"
    MsgBox "正常にファイルを分割しました。" & vbCrLf & "次回からは「" & gstrName & "」を選択して下さい。", 64 + 0, "給与計算システム"
    
    Exit Sub
    
ErrorPrc:
'同じファイル名を指定したとき

    intMsg = MsgBox("すでに同じファイル名があります。" & vbCrLf & "ファイル名を指定して下さい。", 64 + 0, "給与計算")
    mstrNewName = ""
    '名を付けて保存ダイアログボックスを表示
    vntName = Application.GetSaveAsFilename(, "Excel(*.xls),*.xls", , "名を付けて保存")
    'ダイアログボックスのボタン値の検査
    If vntName = False Then GoTo CancelPrc
    '同じファイル名の検査
    If Dir(CStr(vntName)) <> "" Then GoTo ErrorPrc
    'ファイル保存
    mobjWB.SaveAs CStr(vntName)
    gstrName = CStr(vntName) & ".xls"
    MsgBox "正常にファイルを分割しました。" & vbCrLf & "次回からは「" & gstrName & "」を選択して下さい。", 64 + 0, "給与計算システム"
    
    Exit Sub
    
CancelPrc:
'キャンセル時の処理
    vntName = ""
    ChDir mstrDir
    MsgBox "ファイルを分割しませんでした。", 64 + 0, "給与計算システム"
    
    
End Sub

'クラスのインスタンス時
Private Sub Class_Initialize()

    ReDim mobjWS(3) As Worksheet
    Set mobjWB = Workbooks(gstrName)
    Set mobjWS(0) = mobjWB.Worksheets("sheet1")
    Set mobjWS(1) = mobjWB.Worksheets("sheet5")
    Set mobjWS(2) = mobjWB.Worksheets("sheet2") '-----edit 2004/06/09 社員情報
    Set mobjWS(3) = mobjWB.Worksheets("sheet3") '-----edit 2004/06/09 扶養家族情報
    'カレントディレクトリの取得
    mstrDir = CurDir

End Sub

'クラスの開放時
Private Sub Class_Terminate()
    
    Set mobjWB = Nothing
    Set mobjWS(0) = Nothing
    Set mobjWS(1) = Nothing
    '-----edit 2004/06/09
    Set mobjWS(2) = Nothing
    Set mobjWS(3) = Nothing
    
End Sub