Malicious Office (OLE) — malware analysis report

Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If ThisWorkbook.Worksheets("DATA").Cells(1, 1).value <> "" Then
        MsgBox "「メニュー画面」の終了ボタンから終了してください。", 16, "終了"
        Cancel = True
    End If
End Sub


Attribute VB_Name = "Sheet3"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "共通処理"
Option Explicit
Sub 印刷基本情報()
    If MsgBox("プリンタの準備はいいですか？", 4 + 32, "印刷") <> 6 Then Exit Sub
    ActiveSheet.PrintOut
End Sub
Sub 印刷個人情報()
    If MsgBox("プリンタの準備はいいですか？", 4 + 32, "印刷") <> 6 Then Exit Sub
    Range(Cells(6, 2), Cells(Cells(10000, 3).End(xlUp).Row, 7)).PrintOut
End Sub
Sub 対象者へ()
    対象者.Show
End Sub
Sub 並び替えへ()
    並び替え.Show 0
End Sub
Sub MENU(ByVal ファイル名 As String, Optional ByVal ActiveFileName As String = vbNullString)
    
    Application.OnTime Now + TimeValue("00:00:01"), "'CloseActiveWorkbookB """ & ファイル名 & "'"
    ThisWorkbook.Activate
End Sub
Sub CloseActiveWorkbookB(ファイル名 As String)
    Application.ScreenUpdating = False
    If IsOpenBook(ファイル名) Then Workbooks(ファイル名).Close False
    Application.ScreenUpdating = True
End Sub
Sub 印刷Fへ()
    印刷F.Show
End Sub
Sub A保存へ()
    ADa保存.Show
End Sub
Sub 過去データ読込みへ()
    A過去データ.Show
End Sub
Sub 集計へ()
    Dim n As Integer
    Dim i As Integer
    Dim g As Integer
    Dim MSG1 As String
    n = Cells(10000, 3).End(xlUp).Row
    Application.Calculation = xlCalculationManual
    Range("D7:AJ7").FormulaR1C1 = "=COUNTIF(R12C:R" & n & "C,R6C7)" '休業の縦計
    Range("D8:AJ8").FormulaR1C1 = "=COUNTIF(R12C:R" & n & "C,R6C11)＋COUNTIF(R12C:R" & n & "C,R6C20)＋COUNTIF(R12C:R" & n & "C,R6C15)/2" '教育訓練全ての縦計
    Range("AM1:BQ1").FormulaR1C1 = "=COUNTIF(R12C[-35]:R" & n & "C[-35],R6C11)＋COUNTIF(R12C[-35]:R" & n & "C[-35],R6C15)/2" '教育訓練事業所内の縦集計
    Range("AM2:BQ2").FormulaR1C1 = "=COUNTIF(R12C[-35]:R" & n & "C[-35],R6C20）" '教育訓練事業所外の縦集計
    Range("AM10:BQ10").FormulaR1C1 = "=SUM(R12C[-35]:R" & n & "C[-35])" '休業の短時間の縦集計(各日別）
    
    Range("AI12:AI" & n).FormulaR1C1 = "=COUNTIF(RC4:RC34,R6C7)" '休業の横計
    Range("AJ12:AJ" & n).FormulaR1C1 = "=COUNTIF(RC4:RC34,R6C11)+COUNTIF(RC4:RC34,R6C20)+COUNTIF(RC4:RC34,R6C15)/2" '教育訓練全ての横計
    Range("CA12:CA" & n).FormulaR1C1 = "=COUNTIF(RC4:RC34,R6C11)+COUNTIF(RC4:RC34,R6C15)/2" '教育訓練事業場内の横計
    Range("CB12:CB" & n).FormulaR1C1 = "=COUNTIF(RC4:RC34,R6C20)" '教育訓練事業場外の横計
        
    Range("AI7").FormulaR1C1 = "=SUM(RC4:RC34)" '休業縦計の合計値
    Range("AJ8").FormulaR1C1 = "=ROUNDUP(SUM(RC4:RC34),0)" '教育訓練全ての縦計の合計値
    Range("AK8").FormulaR1C1 = "=COUNTA(R12C3:R" & n & "C3)" '氏名欄の人数合計
    
    '20120907 kon
'    Range("C7").FormulaR1C1 = "=COUNTIF(R12C35:R" & n & "C35,"">0"")" '休業の人数
    Range("C7").FormulaR1C1 = "=SUMPRODUCT((R12C35:R" & n & "C35+R12C39:R" & n & "C39>0)*1)"
    
    Range("C8").FormulaR1C1 = "=COUNTIF(R12C36:R" & n & "C36,"">0"")" '教育訓練の人数
    Cells(12, 41).FormulaR1C1 = "=SUMPRODUCT((R12C35:R" & n & "C35+R12C39:R" & n & "C39>0)*1)" '休業の被保険者総数
    Cells(12, 42).FormulaR1C1 = "=COUNTIF(R12C36:R" & n & "C36,"">0"")"  '教育訓練の日保険者総数
    
    Range("AM12:AM" & n).FormulaR1C1 = "=SUM(RC4:RC34)" '休業の短時間の横集計(各人別）
    Range("BS10").FormulaR1C1 = "=INT(SUM(RC39:RC69)+0.9）" '休業の短時間の縦集計(各日別）合計値
    Range("BT1").FormulaR1C1 = "=INT(SUM(RC39:RC69)+0.9）" '教育訓練事業所内の縦集計合計値
    Range("BU2").FormulaR1C1 = "=INT(SUM(RC39:RC69)+0.9）" '教育訓練事業所外の縦集計合計値
        
   
    
    '20120512　masa　様式変更------------------------------------------------------------------------
     '正規職員等の数のチェック
    'Range("AM7:AS8").ClearContents
    'Range("AN12").ClearContents
    '    With Worksheets("休業等対象者")
    '        For i = 12 To Cells(10000, 3).End(xlUp).Row
    '            If Trim(Cells(i, 35).Value) > 0 Or Trim(Cells(i, 39).Value) > 0 Or Trim(Cells(i, 36).Value) > 0 Then  '横計が１以上だったら
    '                If IsError(Application.Match(Cells(i, 3).Value, .Range("C1:C1000"), 0)) = False Then
    '                    g = Application.Match(Cells(i, 3).Value, .Range("C1:C1000"), 0) '行番号
    '                    If .Cells(g, 6).Value = "正規職員" Then
    '                        Cells(7, 39).Value = Cells(7, 39).Value + 1 '正規職員の合計値
    '                        ElseIf .Cells(g, 6).Value = "正規職員以外" Then
    '                        Cells(7, 40).Value = Cells(7, 40).Value + 1
    '                        ElseIf .Cells(g, 6).Value = "派遣労働者" Then
    '                        Cells(7, 41).Value = Cells(7, 41).Value + 1
    '                    End If
    '                    If .Cells(g, 7).Value = "障" Then
    '                        Cells(7, 42).Value = Cells(7, 42).Value + Cells(i, 35).Value '障害有
    '                        Cells(7, 43).Value = Cells(7, 43).Value + Cells(i, 39).Value ' 短時間の障害者の集計　20110418 masa 場所変更した
    '                        Cells(7, 44).Value = Cells(7, 44).Value + Cells(i, 79).Value '教育訓練事業場内　障害者の集計
    '                        Cells(7, 45).Value = Cells(7, 45).Value + Cells(i, 80).Value '教育訓練事業場外　障害者の集計
    '
    '                    End If
    '
    '                    '20110613 入社６か月未満の人はメッセージを表示する
    '                    If IsNumeric(.Cells(g, 5).Value) Then
    ''対象期間の初日と比較するように変更 20110721 kon
    ''                        If fncNenrei(CDate(.Cells(g, 5).Value), Date) <= 0.06 Then
    '                        If fncNenrei(CDate(.Cells(g, 5).Value), Cells(5, 5).Value) < 0.06 Then
    '                            MSG1 = MSG1 & .Cells(g, 3).Value & " " & fcnNenrei & Chr(13)
    '                        End If
    '                    End If
    '
    '                End If
    '            End If
    '        Next
    '
    '    End With---------------------------------------------------------------------------------------------

    '正規職員等の数のチェック
    Range("AM7:AY8").ClearContents
    Range("AN12").ClearContents
    With Worksheets("休業等対象者")
        For i = 12 To Cells(10000, 3).End(xlUp).Row
            If Trim(Cells(i, 35).value) > 0 Or Trim(Cells(i, 39).value) > 0 Or Trim(Cells(i, 36).value) > 0 Then  '横計が１以上だったら
                If IsError(Application.Match(Cells(i, 3).value, .Range("C1:C1000"), 0)) = False Then
                    g = Application.Match(Cells(i, 3).value, .Range("C1:C1000"), 0) '行番号
                        
                        If .Cells(g, 6).value = "正規職員" Then  '休業教育訓練対象者で集計
                            Cells(7, 39).value = Cells(7, 39).value + 1 '正規職員の合計値
                            ElseIf .Cells(g, 6).value = "正規職員以外" Then
                                Cells(7, 40).value = Cells(7, 40).value + 1
                            ElseIf .Cells(g, 6).value = "派遣労働者" Then
                                Cells(7, 41).value = Cells(7, 41).value + 1
                        End If
                        If Trim(Cells(i, 35).value) > 0 Or Trim(Cells(i, 36).value) > 0 Then '休業者のみで集計
                           If .Cells(g, 6).value = "正規職員" Then
                              Cells(7, 46).value = Cells(7, 46).value + 1 '正規職員の合計値
                              ElseIf .Cells(g, 6).value = "正規職員以外" Then
                                Cells(7, 47).value = Cells(7, 47).value + 1
                              ElseIf .Cells(g, 6).value = "派遣労働者" Then
                                Cells(7, 48).value = Cells(7, 48).value + 1
                            End If
                        End If
                        If Trim(Cells(i, 36).value) > 0 Then  '教育訓練のみで集計集計
                           If .Cells(g, 6).value = "正規職員" Then
                              Cells(7, 49).value = Cells(7, 49).value + 1 '正規職員の合計値
                              ElseIf .Cells(g, 6).value = "正規職員以外" Then
                                Cells(7, 50).value = Cells(7, 50).value + 1
                              ElseIf .Cells(g, 6).value = "派遣労働者" Then
                                Cells(7, 51).value = Cells(7, 51).value + 1
                            End If
                        End If
                        
                        If .Cells(g, 7).value = "障" Then
                            Cells(7, 42).value = Cells(7, 42).value + Cells(i, 35).value '障害有
                            Cells(7, 43).value = Cells(7, 43).value + Cells(i, 39).value ' 短時間の障害者の集計　20110418 masa 場所変更した
                            Cells(7, 44).value = Cells(7, 44).value + Cells(i, 79).value '教育訓練事業場内　障害者の集計
                            Cells(7, 45).value = Cells(7, 45).value + Cells(i, 80).value '教育訓練事業場外　障害者の集計
                        End If

                        '20110613 入社６か月未満の人はメッセージを表示する
                        If IsNumeric(.Cells(g, 5).value) Then
                        '対象期間の初日と比較するように変更 20110721 kon
                        ' If fncNenrei(CDate(.Cells(g, 5).Value), Date) <= 0.06 Then
                            If fncNenrei(CDate(.Cells(g, 5).value), Cells(5, 5).value) < 0.06 Then
                                MSG1 = MSG1 & .Cells(g, 3).value & " " & fncNenrei(CDate(.Cells(g, 5).value), Cells(5, 5).value) & Chr(13)
                            End If
                        End If
    
                End If
            End If
        Next
    End With


    Application.Calculation = xlCalculationAutomatic
    Range("AM10:BS10").value = Range("AM10:BS10").Value2
    Range("C7:AP" & n).value = Range("C7:AP" & n).Value2
    Range("AM1:BU2").value = Range("AM1:BU2").Value2
    Cells(12, 40).value = Int(Cells(12, 40).value + 0.9) '短時間の障害者の集計　切り上げる　　20091207 重
    '20110613 入社６か月未満の人はメッセージを表示する
    If MSG1 <> "" Then
        MsgBox "雇用保険資格取得６ヶ月以下の被保険者が存在します。" & Chr(13) & MSG1, 16, "被保険者期間"
    End If
    MsgBox "ＯＫ", 64, aaa
End Sub

Attribute VB_Name = "個人情報"
Attribute VB_Base = "0{2318A52F-4645-4308-A7C2-8AB553CD8BEA}{ABBB4D3B-323E-4386-B828-18317BF201F3}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False


Option Explicit
Private Sub CommandButton1_Click()
    If ListBox1.ListIndex = -1 Then Exit Sub
        TextBox1.value = ListBox1.List(ListBox1.ListIndex, 2)
        TextBox2.value = ListBox1.List(ListBox1.ListIndex, 1)

End Sub

Private Sub CommandButton2_Click()
    If ListBox1.ListIndex = -1 Then Exit Sub
        TextBox3.value = ListBox1.List(ListBox1.ListIndex, 3)
        TextBox4.value = ListBox1.List(ListBox1.ListIndex, 1)
End Sub

Private Sub CommandButton3_Click()
Cells(23, 4).value = TextBox1.value & " " & TextBox2.value
Cells(34, 4).value = TextBox4.value
Cells(35, 4).value = TextBox3.value
Unload Me
End Sub

Private Sub UserForm_Activate()
    Dim i As Integer
    Dim n As Integer
    Dim da As String
    da = ThisWorkbook.Worksheets("DATA").Cells(1, 1).value

    n = 0
    With Workbooks(da).Worksheets("個人情報")
        For i = 6 To .Cells(10000, 2).End(xlUp).Row
            If IsDate(.Cells(i, 29).value) = True And Trim(.Cells(i, 30).value) = "" Then '取得日があって喪失日がない
                ListBox1.AddItem Format(.Cells(i, 2).value, "000000")
                ListBox1.List(n, 1) = .Cells(i, 5).value & " " & .Cells(i, 6).value
                ListBox1.List(n, 2) = .Cells(i, 31).value
                ListBox1.List(n, 3) = .Cells(i, 32).value
                n = n + 1
            End If
        Next
    End With

End Sub

Attribute VB_Name = "並び替え"
Attribute VB_Base = "0{FE184BFA-7B52-4823-A084-F0C5DA79AD30}{6CAA8600-8596-47AA-B0A8-9540A19E34C3}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False


Option Explicit

Private Sub CommandButton1_Click()
    Dim Hani As String
    Dim kii As String
    Hani = "B6:G" & Cells(10000, 3).End(xlUp).Row
    If OptionButton1.value = True Then
        kii = "B6"
        ElseIf OptionButton2.value = True Then
        kii = "E6"
        Else
        kii = "F6"
    End If
    Range(Hani).Sort Key1:=Range(kii), Order1:=xlAscending, Header:=xlNo, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
    :=xlPinYin
    Unload Me

End Sub

Private Sub CommandButton2_Click()
    If ActiveCell.Column <> 3 Or Trim(ActiveCell.value) = "" Then
        MsgBox "シート上で削除したい氏名にカーソルをおいて実行してください。", 16, aaa
        Exit Sub
    End If
    If MsgBox("社員データは「支給申請」が終了するまで必要です。このデータを「削除」してもいいですか？", 4 + 48, aaa) <> 6 Then Exit Sub
    Selection.EntireRow.Delete
    Cells(5, 3).Select
    MsgBox "削除しました。", 64, aaa
    Unload Me
End Sub


Attribute VB_Name = "Open1"
Option Explicit
Public Const aaa As String = "中安金"
Dim シート名 As String
Dim ファイル名  As String
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Sub 初期処理()
     Dim strPathName As String
     Dim myFso       As Scripting.FileSystemObject
     Dim myName      As String
     Dim MyB         As String

     Set myFso = New Scripting.FileSystemObject

     Application.Calculation = xlCalculationAutomatic
     MyB = ThisWorkbook.Worksheets("DATA").Cells(2, 1).value
     strPathName = ThisWorkbook.Path & "\中安金\" & MyB
     If MyB = Dir(strPathName, 16) Then
        Sheets("MENU").Select
        バージョンチェック
     Else
        '初めて開く場合
        Application.ScreenUpdating = True
        Cells(1, 7).value = "初期設定中・・・"
        myName = ThisWorkbook.Path & "\中安金\原本"                                   'コピー元フォルダ
        myFso.CopyFolder myName, strPathName, OverWriteFiles:=True                    'フォルダのコピー
        Cells(1, 7).MergeArea.ClearContents
     End If
     Cells(7, 11).Select
     
        
End Sub
Sub バージョンチェック()
    Dim FileName As String
    Dim Ver As String
    Dim MyB         As String
    
    MyB = ThisWorkbook.Worksheets("DATA").Cells(2, 1).value
    FileName = ThisWorkbook.Path & "\中安金\" & MyB & "\ver.txt"    '会社フォルダのＶｅｒ.txtにバージョン値が記載されている。
    Cells(5, 5).value = GetTextData(1, FileName)                    'Ｖｅｒ.txtのバージョン値を取得
    If Cells(4, 5).value = Cells(5, 5).value Then                   'バージョンが一致していてたら何もしない
        Cells(5, 5).MergeArea.ClearContents
        Exit Sub
    End If
    Application.ScreenUpdating = True
    
    If MsgBox("バージョンアップしますか？", 4 + 32, Cells(4, 5).value) <> 6 Then Exit Sub
    
    Cells(1, 7).value = Cells(4, 5).value & "バージョンアップ中・・・"
    'Da保存フォルダがなかったら作成する
    If Dir(ThisWorkbook.Path & "\中安金\" & MyB & "\Da保存", 16) = "" Then
        MkDir ThisWorkbook.Path & "\中安金\" & MyB & "\Da保存"
    End If
    
    Call 書類入替
    
    Cells(1, 7).MergeArea.ClearContents
    Cells(1, 10).ClearContents
    Cells(5, 5).MergeArea.ClearContents
    
    Application.Run "DaAddin.xla!SetTextData", 1, Cells(4, 5).value, FileName
    MsgBox "完了"
   
End Sub
Sub 書類入替()
    Dim MyB         As String
    Dim OS          As String
    Dim n           As String
    Dim f           As Object
    Dim g           As Object
    Dim Adb         As String
    Dim myBPath     As String
    Dim myFso       As Scripting.FileSystemObject
    
    On Error GoTo ErrorCheck
    
    MyB = ThisWorkbook.Worksheets("DATA").Cells(2, 1).value '会社名
    myBPath = ThisWorkbook.Path & "\中安金\" & MyB & "\"    '会社のフォルダパス
    
    OS = Application.OperatingSystem                        'OSのバージョン情報
    If Right(OS, 4) = "6.00" Or Right(OS, 4) = "6.01" Then
        n = 24 'Vista 7 コメント
        Else
        n = 14 'XP コメント
    End If
    
    Set myFso = New Scripting.FileSystemObject
    Set f = CreateObject("Shell.Application").Namespace(ThisWorkbook.Path & "\中安金\原本\")        '原本フォルダ
    Set g = CreateObject("Shell.Application").Namespace(ThisWorkbook.Path & "\中安金\" & MyB & "\") '会社フォルダ
    
    ファイル名 = Dir(ThisWorkbook.Path & "\中安金\原本" & "\*.xls")  '会社フォルダのエクセルファイル
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Do While ファイル名 <> ""
            
            
            '存在するか否か　存在しない場合は新規書類のためただ入れ込むだけ
            If myFso.FileExists(Filespec:=myBPath & ファイル名) Then
               Else
                myFso.CopyFile ThisWorkbook.Path & "\中安金\原本\" & ファイル名, myBPath
                Cells(1, 10).value = "新規書類" & ファイル名 & "設定中・・・"
            End If
  
            '20110721 kon
            If g.GetDetailsOf(g.ParseName(ファイル名), n) = 10001 Then
                Workbooks.Open myBPath & "\" & ファイル名
                Cells(1, 10).value = ファイル名 & "入れ替え中・・・"
                Workbooks(ファイル名).BuiltinDocumentProperties(5).value = 10002
                Cells(1, 10).value = ""
                
                Workbooks(ファイル名).Save
                Workbooks(ファイル名).Close
            End If
  

            If f.GetDetailsOf(f.ParseName(ファイル名), n) <> g.GetDetailsOf(g.ParseName(ファイル名), n) Then 'コメントに記載されている文字を比較して異なっていたら・・・
                
                Cells(1, 10).value = ファイル名 & "入れ替え中・・・"
                
'                Application.ScreenUpdating = False
                Workbooks.Add
                Adb = ActiveWorkbook.Name

                '新規ブックにシートを移動
                Call シート名取得
                シート移動 MyB, Adb, ファイル名, シート名
                '20120316　masa 複数シートあるため　----------------------------------
                If ファイル名 = "休業手当と平均賃金の計算.xls" Then
                    シート移動 MyB, Adb, ファイル名, "簡易計算"
                    シート移動 MyB, Adb, ファイル名, "平均賃金"
                End If
               ' --------------------------------------------------------------------
               
               
                '新規ブックにシートを移動したファイルをＤａ保存フォルダにバックアップ
'                Workbooks(Adb).SaveAs FileName:=ThisWorkbook.Path & "\中安金\" & MyB & "\Da保存\" & Format(Date, "gemmdd") & "_" & Format(Time, "h_mm ") & "_" & ファイル名 _
                                    , FileFormat:=xlWorkbookNormal
                
                Cells(1, 10).value = ""
                
                Workbooks(Adb).SaveAs FileName:=ThisWorkbook.Path & "\中安金\" & MyB & "\Da保存\vup" & Format(Date, "gemmdd") & "_" & Format(Time, "h_mm ") & "_" & ファイル名 _
                                    , FileFormat:=xlWorkbookNormal
                ActiveWorkbook.Close False

                '原本フォルダのファイルと入替
                myFso.CopyFile ThisWorkbook.Path & "\中安金\原本\" & ファイル名, myBPath '異なっていたら入れる。
'                Application.ScreenUpdating = True
                
            End If
            ファイル名 = Dir()
            
    Loop
    
    '20120712 masa 基本手当日額いれる
    Workbooks.Open FileName:=myBPath & "Master.xls"
    With Worksheets("会社基本情報")
        If .Cells(42, 4).value <> GetTextData(2, ThisWorkbook.Path & "\中安金\原本\ver.txt") Then
           .Cells(42, 4).value = GetTextData(2, ThisWorkbook.Path & "\中安金\原本\ver.txt")
           Workbooks("Master.xls").Save
        End If
    End With
    Workbooks("Master.xls").Close False
    
    
    
    Set f = Nothing
    Set g = Nothing
    Set myFso = Nothing
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    Exit Sub

ErrorCheck:
    MsgBox "バージョンアップに失敗しました。"
    Cells(1, 7).MergeArea.ClearContents
    Cells(1, 10).ClearContents
    Cells(5, 5).MergeArea.ClearContents
    End
End Sub
Sub シート名取得()
    Select Case ファイル名
        Case "予定表.xls"
              シート名 = "予定"
        Case "休業等実施計画届.xls"
              シート名 = "実施計画届"
        Case "休業協定書.xls"
              シート名 = "休業協定書"
        Case "5号3実績一覧表.xls"
              シート名 = "実績表"
        Case "教育訓練協定書.xls"
              シート名 = "教育訓練協定書"
        Case "5号2助成額算定書.xls"
              シート名 = "第105号の2"
        Case "休業等支給申請書.xls"
              シート名 = "支給申請書"
        Case "雇用維持事業主申告書.xls"
              シート名 = "雇用維持事業主申告書"
        Case "労働者代表選任届.xls"
              シート名 = "労働者選任届"
        Case "賃金支払確認書.xls"
              シート名 = "確認書"
        Case "事業活動の状況に関する申出書地震.xls"
              シート名 = "円高の影響"
        Case "事業活動の状況に関する申出書円高.xls"
              シート名 = "円高の影響"
        Case "事業活動の状況に関する申出書.xls"
              シート名 = "雇用状況申出書"
        Case "支給申請確認書.xls"
              シート名 = "支給申請確認書"
        Case "雇用維持事業主申告書.xls"
              シート名 = "雇用維持事業主申告書"
        Case "契約期間遵守証明書.xls"
              シート名 = "派遣契約期間遵守証明書"
        Case "休業手当と平均賃金の計算.xls"
              シート名 = "休業手当"
        Case "Master.xls"
              シート名 = "休業等対象者"
        Case "委任状.xls"
              シート名 = "委任状"
        Case "年間休日表の作成.xls"
              シート名 = "休日1"
         Case "結果表.xls"
              シート名 = "結果"
        
'20111101　kon　円高の影響１箇月追加
        Case "事業活動の状況に関する申出書円高の影響.xls"
              シート名 = "円高の影響１箇月"
        
        
        End Select
    
End Sub

Sub 会社基本情報へ()
    Application.ScreenUpdating = False
    FileOpen1 ("Master.xls")
    Worksheets("会社基本情報").Select
    Application.ScreenUpdating = True
End Sub
Sub 休業等対象者へ()
    Application.ScreenUpdating = False
    FileOpen1 ("Master.xls")
    Worksheets("休業等対象者").Select
    Application.ScreenUpdating = True
End Sub
Sub 計画届へ()
   FileOpen1 ("休業等実施計画届.xls")
End Sub
Sub 事業活動の状況へ()
   FileOpen1 ("事業活動の状況に関する申出書.xls")
End Sub
Sub 事業活動円高の状況へ()
   FileOpen1 ("事業活動の状況に関する申出書円高.xls")
End Sub

'20111101  kon 円高の影響1箇月追加
Sub 事業活動円高の状況1箇月へ()
   FileOpen1 ("事業活動の状況に関する申出書円高の影響.xls")
End Sub

Sub 事業活動地震の状況へ()
   FileOpen1 ("事業活動の状況に関する申出書地震.xls")
End Sub
'20121001kon
Sub 事業活動電力の状況へ()
   FileOpen1 ("事業活動の状況に関する申出書(電力制限).xls")
End Sub
'20121001kon
Sub 事業活動電力2の状況へ()
   FileOpen1 ("事業活動の状況に関する申出書(電力事業主).xls")
End Sub



Sub 休業協定書へ()
   FileOpen1 ("休業協定書.xls")
End Sub
Sub 休業教育訓練協定書へ()
   FileOpen1 ("教育訓練協定書.xls")
End Sub
Sub 労働者代表選任届へ()
   FileOpen1 ("労働者代表選任届.xls")
End Sub
Sub 委任状へ()
   FileOpen1 ("委任状.xls")
End Sub
Sub 支給申請確認へ()
   FileOpen1 ("支給申請確認書.xls")
End Sub
Sub 雇用維持事業主申告書へ()
   FileOpen1 ("雇用維持事業主申告書.xls")
End Sub
Sub 契約期間遵守証明書へ()
   FileOpen1 ("契約期間遵守証明書.xls")
End Sub
Sub 賃金支払確認書へ()
   FileOpen1 ("賃金支払確認書.xls")
End Sub
Sub 休業手当と平賃へ()
'   FileOpen1 ("休業手当と平均賃金の計算.xls")
'20120316　masa -------------------------------------
    Dim wb  As Workbook
    Dim MyB As String
    For Each wb In Workbooks
        If wb.Name = "休業手当と平均賃金の計算.xls" Then
            wb.Activate
            Exit For
        End If
    Next
    
    MyB = ThisWorkbook.Worksheets("DATA").Cells(2, 1).value
    If ActiveWorkbook.Name <> ファイル名 Then
        Workbooks.Open ThisWorkbook.Path & "\中安金\" & MyB & "\" & "休業手当と平均賃金の計算.xls"
        Application.Run "休業手当と平均賃金の計算.xls!初期処理"
    End If
   '-----------------------------------------------------------
   
   
End Sub
Sub 年間休日表へ()
   FileOpen1 ("年間休日表の作成.xls")
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    FileOpen1 ("Master.xls")
        
    会社名読み込み "年間休日表の作成.xls", "休日2", "V54", "V55", "V56"
    
    FileClose1 ("Master.xls")
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub
Sub 支給申請書へ()
   FileOpen1 ("休業等支給申請書.xls")
   Txt読み込み1
End Sub
Sub 予定表へ()
   
   FileOpen2 "予定表.xls", "予定表", "AF45", "AF46", "AF47"
   
'20120326 kon
   Worksheets("予定").Select
   Cells(1, 1).Select
   
End Sub
Sub 結果表へ()
   FileOpen2 "結果表.xls", "結果表", "AF45", "AF46", "AF47"
   '20120326 kon
   Worksheets("結果").Select
   Cells(1, 1).Select

End Sub
Sub 実績表へ()
    FileOpen2 "5号3実績一覧表.xls", "実績表", "AH37", "AH35", "AH36"
'20120326 kon
   Worksheets("実績表").Select
   Cells(1, 1).Select

End Sub
Sub 助成額算定へ()
    FileOpen3 "5号2助成額算定書.xls"
'20120326 kon
   Worksheets("第105号の2").Select
   Cells(1, 1).Select

End Sub
Sub 裏面へ()
  Call ShellExecute(0, "open", ThisWorkbook.Path & "\5号の1裏面.pdf", vbNullString, vbNullString, 1)
End Sub
Sub 実績一覧裏面へ()
  Call ShellExecute(0, "open", ThisWorkbook.Path & "\実績一覧裏面.pdf", vbNullString, vbNullString, 1)
End Sub
'20120604 YBNO#15934 kon
Sub 休業実施計画裏面へ()
  Call ShellExecute(0, "open", ThisWorkbook.Path & "\1号の1裏面.pdf", vbNullString, vbNullString, 1)
End Sub

'20121001 kon
Sub 助成額算定書裏面へ()
  Call ShellExecute(0, "open", ThisWorkbook.Path & "\助成額算定書裏面.pdf", vbNullString, vbNullString, 1)
End Sub
'20121001 kon
Sub 申出書裏面()
  Call ShellExecute(0, "open", ThisWorkbook.Path & "\1号の2裏面.pdf", vbNullString, vbNullString, 1)
End Sub
'20121001 kon
Sub 申出書96裏面()
  Call ShellExecute(0, "open", ThisWorkbook.Path & "\96号裏面.pdf", vbNullString, vbNullString, 1)
End Sub
'20121001 kon
Sub 申出書97裏面()
  Call ShellExecute(0, "open", ThisWorkbook.Path & "\97号裏面.pdf", vbNullString, vbNullString, 1)
End Sub



Attribute VB_Name = "対象者"
Attribute VB_Base = "0{1443E144-4853-41D7-AB49-56223DD0ECEC}{245791AE-3930-439E-9EBF-5E36F3CBE1A7}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False

Option Explicit
Dim da As String

Private Sub CommandButton1_Click()
    Dim n As Integer
    Dim j As Integer
    Dim i As Integer
    j = Cells(10000, 3).End(xlUp).Row + 1
    Application.Calculation = xlCalculationManual
    If j > 6 Then
        n = MsgBox("すでにデータが存在します。" & Chr(10) & "追加して登録する場合は「はい」を" & Chr(10) & "現在データをクリアして登録する場合は「いいえ」を" & Chr(10) & "処理を中止する場合は「キャンセル」をクリックしてください。", 3 + 32, aaa)
        If n = 2 Then Exit Sub
        If n = 6 Then '追加登録
            Else
            Range(Cells(6, 2), Cells(j, 6)).ClearContents 'クリアして登録
            j = 6
        End If
    End If
    With Workbooks(da).Worksheets("個人情報")
        For i = 0 To ListBox1.ListCount - 1
            If ListBox1.Selected(i) = True Then
                Cells(j, 2).value = .Cells(Val(ListBox1.List(i, 0)), 31) '所属
                Cells(j, 3).value = ListBox1.List(i, 2) '名前
                Cells(j, 4).value = .Cells(Val(ListBox1.List(i, 0)), 26) '雇用保険番号
                Cells(j, 5).value = .Cells(Val(ListBox1.List(i, 0)), 29) '取得日
                Cells(j, 6).value = ComboBox1.value
                j = j + 1
            End If
        Next
    End With
    Unload Me
End Sub

Private Sub OptionButton1_Click()
    Dim i As Integer
    Dim n As Integer
    ListBox1.Clear
    n = 0
    With Workbooks(da).Worksheets("個人情報")
        For i = 6 To .Cells(10000, 2).End(xlUp).Row
            If IsDate(.Cells(i, 29).value) = True And Trim(.Cells(i, 30).value) = "" Then '取得日があって喪失日がない
                ListBox1.AddItem i
                ListBox1.List(n, 1) = Format(.Cells(i, 2).value, "000000")
                ListBox1.List(n, 2) = .Cells(i, 5).value & " " & .Cells(i, 6).value
                n = n + 1
            End If
        Next
    End With
    For i = 0 To ListBox1.ListCount - 1
        ListBox1.Selected(i) = True
    Next
End Sub

Private Sub OptionButton3_Click()
    Dim i As Integer
    For i = 0 To ListBox1.ListCount - 1
        ListBox1.Selected(i) = False
    Next
End Sub
Private Sub UserForm_Activate()
    da = ThisWorkbook.Worksheets("DATA").Cells(1, 1).value
    OptionButton1.value = True
    ComboBox1.AddItem "正規職員"
    ComboBox1.AddItem "正規職員以外"
    ComboBox1.AddItem "派遣労働者"
    ComboBox1.ListIndex = 0
End Sub
Private Sub OptionButton2_Click()
    Dim i As Integer
    Dim n As Integer
    ListBox1.Clear
    n = 0
    With Workbooks(da).Worksheets("個人情報")
        For i = 6 To .Cells(10000, 2).End(xlUp).Row
            If Trim(.Cells(i, 15).value) = "" Then '退社日がない
                ListBox1.AddItem i
                ListBox1.List(n, 1) = Format(.Cells(i, 2).value, "000000")
                ListBox1.List(n, 2) = .Cells(i, 5).value & " " & .Cells(i, 6).value
                n = n + 1
            End If
        Next
    End With
    For i = 0 To ListBox1.ListCount - 1
        ListBox1.Selected(i) = True
    Next

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Application.Calculation = xlCalculationAutomatic
End Sub

Attribute VB_Name = "Function1"
Option Explicit
Function IsOpenBook(ByVal Name As String) As Boolean

    Dim wb As Workbook
    Dim ret As Boolean
    
    ret = False
    
    For Each wb In Workbooks
        If wb.Name = Name Then
            ret = True
            Exit For
        End If
    Next wb

    IsOpenBook = ret

End Function
Public Function GetTextData(ByVal i As Integer, ByVal FileName As String) As String
  
    Dim buffer() As String '文字列受け取り用
    
    GetStringArray buffer, FileName

    GetTextData = buffer(i - 1)

End Function
Function Hani(範囲 As String)
    Dim i As Integer
    For i = 1 To Len(範囲)
        If Mid(範囲, i, 1) = ":" Then
            Hani = Left(範囲, i - 1) & ":"
            Exit For
        End If
    Next
    For i = Len(範囲) To 1 Step -1
        If Mid(範囲, i, 1) = ":" Then
            Hani = Hani & Right(範囲, Len(範囲) - i)
            Exit For
        End If
    Next
End Function
Public Sub GetStringArray(ByRef str() As String, ByVal FileName As String)

    Dim FileNumber As Integer 'ファイル番号
    Dim LineCount As Integer '行数

    '初期処理
    FileNumber = FreeFile
    LineCount = 0

    'DOTO FreeFileで番号を得ること
    Open FileName For Input As FileNumber

        Do While Not EOF(FileNumber)
            'ファイルの長さで配列をデータを保持しながら初期化
            ReDim Preserve str(LineCount)
    
            'ファイルをバイナリで読み込んで配列に格納
            Line Input #FileNumber, str(LineCount)
            LineCount = LineCount + 1
        Loop
           
    Close #FileNumber

End Sub
Sub FileOpen1(ファイル名 As String)
    Dim wb  As Workbook
    Dim MyB As String
    For Each wb In Workbooks
        If wb.Name = ファイル名 Then
            wb.Activate
            Exit For
        End If
    Next
    
    MyB = ThisWorkbook.Worksheets("DATA").Cells(2, 1).value
    If ActiveWorkbook.Name <> ファイル名 Then
    '20120830 kon YBNO 18539
        DoEvents
        Workbooks.Open ThisWorkbook.Path & "\中安金\" & MyB & "\" & ファイル名
    End If
End Sub
Sub FileOpen2(ファイル名, シート, A, B, C As String)
    Dim wb  As Workbook
    Dim MyB As String
    For Each wb In Workbooks
        If wb.Name = ファイル名 Then
            wb.Activate
            Exit For
        End If
    Next
    
    MyB = ThisWorkbook.Worksheets("DATA").Cells(2, 1).value
    If ActiveWorkbook.Name <> ファイル名 Then
        Workbooks.Open ThisWorkbook.Path & "\中安金\" & MyB & "\" & ファイル名
        従業員データ読み込み ファイル名, シート, A, B, C
    End If
End Sub
Sub FileOpen3(ファイル名 As String)
    Dim wb  As Workbook
    Dim MyB As String
    For Each wb In Workbooks
        If wb.Name = ファイル名 Then
            wb.Activate
            Exit For
        End If
    Next
    
    MyB = ThisWorkbook.Worksheets("DATA").Cells(2, 1).value
    If ActiveWorkbook.Name <> ファイル名 Then
        Workbooks.Open ThisWorkbook.Path & "\中安金\" & MyB & "\" & ファイル名
        Workbooks(ファイル名).Activate
        結果表読込 ("第105号の2")
    End If
End Sub
Sub FileOpen4(ファイル名 As String)
    Dim wb  As Workbook
    Dim MyB As String
    For Each wb In Workbooks
        If wb.Name = ファイル名 Then
            wb.Activate
            Exit For
        End If
    Next
    
    MyB = ThisWorkbook.Worksheets("DATA").Cells(2, 1).value
    If ActiveWorkbook.Name <> ファイル名 Then
        Workbooks.Open ThisWorkbook.Path & "\中安金\" & MyB & "\Da保存\" & ファイル名
    End If
End Sub
Sub FileClose1(ファイル名 As String)
    If Workbooks(ファイル名).Saved Then
        Workbooks(ファイル名).Close False
    Else
        Workbooks(ファイル名).Save
        Workbooks(ファイル名).Close False
    End If
End Sub
Sub 従業員データ読み込み(ファイル, シート, A, B, C As String)
    Dim n As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
     
    With ActiveWorkbook.Worksheets("休業等対象者") '休業等対象者をクリアする。
        Range(.Cells(3, 2), .Cells(.Cells(10005, 3).End(xlUp).Row, 6)).ClearContents
    End With
    
    FileOpen1 ("Master.xls")
    Workbooks("Master.xls").Activate
    Worksheets("休業等対象者").Select
    n = Cells(10005, 3).End(xlUp).Row '最終行取得
    Range(Cells(6, 2), Cells(n, 7)).Copy
    
    Workbooks(ファイル).Activate
    Worksheets("休業等対象者").Cells(6, 2).PasteSpecial Paste:=xlPasteValues
    
    会社名読み込み ファイル, シート, A, B, C
    
    Application.CutCopyMode = False
    FileClose1 ("Master.xls")
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub
Sub 会社名読み込み(ファイル, シート, A, B, C As String)
         
    Workbooks(ファイル).Activate
    
    With Worksheets(シート)
        .Range(A).value = Workbooks("Master.xls").Worksheets("会社基本情報").Cells(7, 4).value '事業主住所
        .Range(B).value = Workbooks("Master.xls").Worksheets("会社基本情報").Cells(8, 4).value '名称
        .Range(C).value = Workbooks("Master.xls").Worksheets("会社基本情報").Cells(9, 4).value '代表者
        
        Select Case シート
            Case "結果表"
                Worksheets("DATA1").Cells(40, 3).value = Workbooks("Master.xls").Worksheets("会社基本情報").Cells(40, 4).value  '労働時間
                Worksheets("DATA1").Cells(42, 3).value = Workbooks("Master.xls").Worksheets("会社基本情報").Cells(22, 4).value  '雇用保険事業所番号
                Worksheets("DATA1").Cells(20, 3).value = Workbooks("Master.xls").Worksheets("会社基本情報").Cells(42, 4).value  '日額

            Case "実績表"
                .Range(A).value = Workbooks("Master.xls").Worksheets("会社基本情報").Cells(34, 4).value '従業員代表
                Call 結果表読込("実績表")
        End Select
        
    End With
    
End Sub
Sub 結果表読込(シート As String)
…