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
Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.Calculation = xlCalculationAutomatic
    ThisWorkbook.Saved = True
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    MsgBox "このファイルは保存できません。", 16, "保存"
    Cancel = True
End Sub




Attribute VB_Name = "Sheet31"
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
Option Explicit


Attribute VB_Name = "Sheet30"
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 = "非表示"
Attribute VB_Base = "0{E93A1F9F-BCAF-4F9F-B67E-5FCDB032EAFC}{15EA97B6-61D5-4F86-8250-CF194036992C}"
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 i As Integer
    Dim n As Integer

    For i = 0 To 11
        If ListBox1.Selected(i) = True Then
            Cells(111, 4 + i).Value = 1
        Else
            Cells(111, 4 + i).Value = 0
        End If
    Next
    For i = 12 To 15
        If ListBox1.Selected(i) = True Then
            Cells(111, 7 + i).Value = 1
        Else
            Cells(111, 7 + i).Value = 0
        End If
    Next

    Unload Me
    MsgBox "OK", 64, "表示"

End Sub

Private Sub UserForm_Activate()
    Dim i As Integer
    Dim n As Integer
    n = 0
    For i = 4 To 15
        ListBox1.AddItem Cells(6, i).Value
    Next
    ListBox1.AddItem "賞与1"
    ListBox1.AddItem "賞与2"
    ListBox1.AddItem "賞与3"
    ListBox1.AddItem "賞与4"
    For i = 0 To 11
        If Cells(111, 4 + i).Value = 1 Then
            ListBox1.Selected(i) = True
        End If
    Next
    For i = 12 To 15
        If Cells(111, 7 + i).Value = 1 Then
            ListBox1.Selected(i) = True
        End If
    Next
    

End Sub

Attribute VB_Name = "Module1"
'************************
'修正履歴：
'       部門部課合計を表示した場合に、右上の性別や生年月日等が残る     20080911 kon
'       印刷時固まるため   20090909 kon
'************************
Option Explicit
Public Const AAA As String = "賃金台帳"
    Dim Zkk As String
    Dim Zho As String
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim Nen As Long

Sub 印刷へ()
If MsgBox("プリンタの準備はいいですか？", 1 + 32, "印刷") <> 1 Then Exit Sub
ActiveSheet.PageSetup.CenterHeader = "&""ＭＳ Ｐゴシック""&14賃金台帳"
Call 非表示チェック
'20090909 kon
DoEvents
ActiveSheet.PrintOut
'20090909 kon
DoEvents
End Sub
Sub 閉じる()
    Application.ScreenUpdating = False
    On Error Resume Next
    If Worksheets("読込ファイル").Cells(5, 1).Value = "前年" Then
        Workbooks(Zkk).Close False
        Workbooks(Zho).Close False
        Kill ThisWorkbook.Path & "\" & Nen & "\" & Zkk
        Kill ThisWorkbook.Path & "\" & Nen & "\" & Zho
    ElseIf Worksheets("読込ファイル").Cells(5, 1).Value = "自至" Then
        Workbooks("賃金台帳.xls").Close False
    End If
    
    Application.Run "CellsKyuyoTool.xla!閉じる"
End Sub
Sub Auto_Open()
    Dim MyFile As String
    Dim i As Integer
    Application.Calculation = xlCalculationManual
    With Worksheets("読込ファイル")
        If .Cells(5, 1).Value = "自至" Then '前年から本年モード
        MyFile = .Cells(6, 1).Value
        Else
        MyFile = .Cells(1, 1).Value
        End If
        
    End With
    Sheets("個人別合計一覧").Select
    ActiveSheet.EnableSelection = xlUnlockedCells
    ActiveSheet.Protect UserInterfaceOnly:=True
    ActiveWindow.DisplayHeadings = False
    Sheets("賃金台帳").Select
    ActiveWindow.DisplayWorkbookTabs = False
    ActiveSheet.EnableSelection = xlUnlockedCells
    ActiveSheet.Protect UserInterfaceOnly:=True
    ActiveWindow.DisplayHeadings = False
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
     With Workbooks(MyFile).Worksheets("給与支給控除")
        Range("C43:C98").Value = .Range("C49:C104").Value '支給控除項目
        Range("C8:C36").Value = .Range("C14:C42").Value '勤怠項目
        
        Range("E3:E4").Value = ""
        Rows("8:36").Hidden = False
        For i = 8 To 36 '勤怠、給与支給控除で非表示になっているものは非表示とする
            If .Rows(i + 6).Hidden = True Or Cells(i, 3).Value = 0 Then
                Rows(i).Hidden = True
            End If
        Next
        For i = 43 To 98 '給与支給控除で非表示になっているものは非表示とする
            If Rows(i).Hidden <> .Rows(i + 6).Hidden Then
                Rows(i).Hidden = .Rows(i + 6).Hidden
            End If
        Next
    End With
    With Workbooks(MyFile).Worksheets("賞与支給控除")
        Range("R43:R98").Value = .Range("C49:C104").Value '支給控除項目
    End With

'
    MyFile = Left(MyFile, Len(MyFile) - 6) & "保存データ.xls"
    With Workbooks(MyFile) '20110131　重
        If .Worksheets("賞与３").Cells(5, 2).Value = "" Then
            Columns("U:U").Hidden = True
            Else
            Columns("U:U").Hidden = False
        End If
            
        If .Worksheets("賞与４").Cells(5, 2).Value = "" Then
            Columns("V:V").Hidden = True
            Else
            Columns("V:V").Hidden = False
        End If
    End With

    Application.Calculation = xlAutomatic
    Application.Calculation = xlCalculationManual
    Range("D8:P36,X8:X36").NumberFormatLocal = "0.00;-0.00;"
    Range("D8:O36").FormulaR1C1 = _
        "=IF(R105C=0,,INDIRECT(R109C3&R106C&""'!R""&R105C&""C""&ROW()-2,0))"
    Application.Calculation = xlAutomatic
    Application.Calculation = xlCalculationManual
    For i = 8 To 36
        If Cells(i, 1).Value = True Then
        Range(Cells(i, 4), Cells(i, 16)).NumberFormatLocal = "[h]:mm;;"
        Cells(i, 24).NumberFormatLocal = "[h]:mm;;"
        Range(Cells(i, 4), Cells(i, 15)).FormulaR1C1 = _
            "=IF(R105C=0,,Zikan(INDIRECT(R109C3&R106C&""'!R""&R105C&""C""&ROW()-2,0)))"
        End If
    Next
    DoEvents
    ThisWorkbook.Activate
    DoEvents
    ActiveSheet.Shapes("ko").Visible = True
    ActiveSheet.Shapes("ho").Visible = False
    Application.Calculation = xlAutomatic
    If Worksheets("読込ファイル").Cells(5, 1).Value = "給与" Then
    ActiveSheet.Shapes("ho").Visible = True
    End If
    If Worksheets("読込ファイル").Cells(5, 1).Value = "自至" Then
    Range("D106:O106").Value = Workbooks("賃金台帳.xls").Worksheets("賃金台帳").Range("D6:O6").Value
    ActiveSheet.Shapes("ko").Visible = False
    End If
    Application.ScreenUpdating = True
    

End Sub
Sub 前年初期処理()
    Dim kk As String
    Dim 保存 As String

    
    
    Dim S As Worksheet
    Dim FSO As Object
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    '前年ファイルを名前を替えて読み込む
    Nen = Worksheets("読込ファイル").Cells(4, 1).Value
    Set FSO = CreateObject("Scripting.FileSystemObject")
    kk = Worksheets("読込ファイル").Cells(1, 1).Value
    Zkk = "ZennenCopy" & Format(Now, "geemmddhhmmss") & "kk.xls"
    Zho = Left(Zkk, Len(Zkk) - 6) & "保存データ.xls"
    保存 = Left(kk, Len(kk) - 6) & "保存データ.xls"
    Application.Calculation = xlCalculationManual
    FSO.Copyfile ThisWorkbook.Path & "\" & Nen & "\" & kk, ThisWorkbook.Path & "\" & Nen & "\" & Zkk
    FSO.Copyfile ThisWorkbook.Path & "\" & Nen & "\" & 保存, ThisWorkbook.Path & "\" & Nen & "\" & Zho
    Workbooks.Open ThisWorkbook.Path & "\" & Nen & "\" & Zkk
'    Worksheets("MENU").Unprotect
'    Worksheets("MENU").Cells(1, 1).Value = "" '念のため（閉じられないといけないので）
     '#30342 20160219 ishikawa
    Workbooks(Zkk).Worksheets("MENU").Unprotect
    Workbooks(Zkk).Worksheets("MENU").Cells(1, 1).Value = "" '念のため（閉じられないといけないので）

    Workbooks.Open ThisWorkbook.Path & "\" & Nen & "\" & Zho
'    Worksheets("DATA").Unprotect
'    Worksheets("DATA").Cells(1, 1).Value = ""
    '#30342 20160219 ishikawa
    Workbooks(Zho).Worksheets("DATA").Unprotect
    Workbooks(Zho).Worksheets("DATA").Cells(1, 1).Value = ""
    ThisWorkbook.Activate
    Workbooks(Zkk).Saved = True
    Workbooks(Zho).Saved = True
    Windows(Zkk).Visible = False
    Windows(Zho).Visible = False
    Worksheets("読込ファイル").Cells(1, 1).Value = Zkk
    Application.Calculation = xlCalculationAutomatic

    Call Auto_Open
End Sub
Sub 終了()
    ThisWorkbook.Worksheets("MENU").Cells(1, 1).Value = "" '終了できない印を解除
    On Error Resume Next
    Workbooks(Zkk).Close False
    Workbooks(Zho).Close False
    Kill ThisWorkbook.Path & "\" & Zkk
    Kill ThisWorkbook.Path & "\" & Zho
    Application.Run "CellsKyuyoTool.xla!閉じる"

End Sub

Sub 個人選択へ()
個人選択.Show 0
End Sub
Sub 個人別選択へ()
If Cells(201, 3).Value = "" Then
MsgBox "集計を行ってから実行してください。", 16, "個人選択"
Exit Sub
End If
個人別選択.Show
End Sub
Sub 個人別合計一覧へ()
    Sheets("個人別合計一覧").Select
End Sub
Sub 賃金台帳へ()
Sheets("賃金台帳").Select
End Sub
Sub 合計へ()
部門入力.Show
End Sub
Sub 表示項目へ()
表示項目.Show
End Sub
Sub 個人別集計()
    Dim MyFile As String
    Dim i As Integer
    Dim n As Integer
    Dim j As Integer
    
    MyFile = Worksheets("読込ファイル").Cells(1, 1).Value

    j = 0
    '○月分まで入力されているのか
    
        For i = 12 To 1 Step -1
            With Workbooks(Left(MyFile, Len(MyFile) - 6) & "保存データ.xls").Worksheets(i & "月")
                If .Cells(8, 2).Value <> "" Then
                    j = i
                    Exit For
                End If
            End With
        Next
    
    If j = 0 Then
    MsgBox "保存データにデータがありません。", 16, "賃金台帳"
    Exit Sub
    End If
    
    Cells(3, 5).Value = "集計しています。しばらくお待ちください・・・"
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    With Worksheets("賃金台帳") '20121212　titti
        .Range("H109:H110").ClearContents '部門部課印をクリア
        .Range("F109").ClearContents '部門をクリア
        Application.Calculation = xlCalculationAutomatic
        Application.Calculation = xlCalculationManual
        For i = 8 To 98
            If Rows(i).Hidden <> .Rows(i).Hidden Then '賃金台帳の行と一緒の形式にする
            Rows(i).Hidden = .Rows(i).Hidden
            End If
        Next
        .Range("C8:D98").Copy '項目名と勤怠の書式をコピーする
        Range("C8").PasteSpecial Paste:=xlPasteValues
        Range("C8").PasteSpecial Paste:=xlPasteFormats
        Range("D4:D36").ClearContents
        Range("D8:D36").Copy
        Range("E8:T8").PasteSpecial Paste:=xlPasteAllExceptBorders
        Application.CutCopyMode = False
        Range("F11").Select
    End With

    
    
    n = WorksheetFunction.Count("C201:C1300") + 5
    Range("C201:CS" & (201 + n)).ClearContents
    With Workbooks(MyFile).Worksheets("個人情報")
        For i = 0 To 1000
            If .Cells(6 + i, 2).Value = "" Then Exit For
            Worksheets("賃金台帳").Cells(3, 5).Value = .Cells(6 + i, 2).Value
            Application.Calculation = xlCalculationAutomatic
            Application.Calculation = xlCalculationManual
            Cells(201 + i, 3).Value = .Cells(6 + i, 2).Value 'No
            Cells(201 + i, 4).Value = .Cells(6 + i, 3).Value '氏名
            Cells(3, 5).Value = Cells(201 + i, 4).Value & "さんを集計中"
            Application.ScreenUpdating = True
            Application.ScreenUpdating = False
            Cells(201 + i, 5).Value = Worksheets("賃金台帳").Cells(4, 8).Value '部門
            Cells(201 + i, 6).Value = Worksheets("賃金台帳").Cells(4, 11).Value '部課
            Worksheets("賃金台帳").Range("X8:X98").Copy
            Range("G" & (201 + i)).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
        Next
'    Worksheets("賃金台帳").Range("E3:E4").ClearContents
    Cells(3, 5).Value = ""
    Cells(3, 4).Value = "1月 ～ " & j & "月分"
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    End With
MsgBox "集計が終了しました。出力する社員を選択してください。", 64, "集計"
個人別選択.Show
End Sub
Sub 簡易表示()
    Dim MyFile As String
    Dim i As Integer
    Application.Calculation = xlManual
    MyFile = Worksheets("読込ファイル").Cells(1, 1).Value
    Sheets("賃金台帳").Select
    ActiveSheet.Unprotect
     With Workbooks(MyFile).Worksheets("給与支給控除")
        Range("C43:C98").Value = .Range("C49:C104").Value '支給控除項目
        Range("C8:C32").Value = .Range("C14:C38").Value '勤怠項目
        For i = 8 To 22 '勤怠、給与支給控除で非表示になっているものは非表示とする
            If Rows(i).Hidden <> .Rows(i + 6).Hidden Then
                Rows(i).Hidden = .Rows(i + 6).Hidden
            End If
        Next
        For i = 43 To 98 '給与支給控除で非表示になっているものは非表示とする
            If Rows(i).Hidden <> .Rows(i + 6).Hidden Then
                Rows(i).Hidden = .Rows(i + 6).Hidden
            End If
        Next
    
    End With
    Application.Calculation = xlCalculationAutomatic
    Workbooks.Open ThisWorkbook.Path & "\賃金台帳簡易版.xls"
    Sheets("賃金台帳").Select
    ActiveSheet.EnableSelection = xlUnlockedCells
    ActiveSheet.Protect UserInterfaceOnly:=True
    Range("C3:X100").Value = ThisWorkbook.Worksheets("賃金台帳").Range("C3:X100").Value2
    For i = 6 To 98 '勤怠付で表示するため項目がないものは非表示（詰める）とする
        If Rows(i).Hidden = False Then
            If Cells(i, 3).Value = 0 Then
                Rows(i).Hidden = True
            End If
        End If
    Next
    ActiveWindow.DisplayHeadings = False
    ActiveWindow.DisplayWorkbookTabs = False
    ThisWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

Attribute VB_Name = "部門入力"
Attribute VB_Base = "0{D12EEF77-B9E8-4DD7-9C2B-C29660BDF1FC}{F31DA16D-6FAC-45C4-825A-EF56B9EC2A7B}"
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 n As Long

Private Sub CommandButton1_Click()
    If ListBox1.ListIndex = -1 Then
    MsgBox "リストを選択してから実行してください。", 16, AAA
    Exit Sub
    End If
    Range("H109:H110").ClearContents
    '20080911 add kon
    Cells(109, 6).Value = 1
    
    Cells(3, 5).Value = ""
    Cells(4, 5).Value = "合　　     計"
    If OptionButton1.Value = True Then
        Cells(109, 8).Value = ListBox1.ListIndex + 1
    Else
        Cells(110, 8).Value = ListBox1.ListIndex + 1
    End If
Unload Me
End Sub

Private Sub CommandButton2_Click()
Range("H109:H110").ClearContents
Cells(109, 6).Value = 1
Cells(3, 5).Value = ""
Cells(4, 5).Value = "合　　     計"
Unload Me
End Sub
Private Sub OptionButton1_Click()
Call リスト切替("T") '部門
End Sub

Private Sub OptionButton2_Click()
Call リスト切替("W") '部課
End Sub
Private Sub リスト切替(MyC As String)
    '部門と部課の切替
    Dim MyFile As String
    MyFile = Worksheets("読込ファイル").Cells(1, 1).Value
    Me.Caption = IIf(MyC = "T", "部門", "部課") & "リスト"
    ListBox1.Clear
    With Workbooks(MyFile).Worksheets("基本項目")
        If .Range(MyC & "5").Value = "" Then Exit Sub
        If .Range(MyC & "6").Value = "" Then
            ListBox1.AddItem .Range(MyC & "5").Value
            Else
            ListBox1.List = .Range(MyC & "5:" & MyC & .Range(MyC & "105").End(xlUp).Row).Value
        End If
    End With

End Sub

Private Sub UserForm_Activate()
Application.Calculation = xlManual
OptionButton1.Value = True
End Sub

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

Attribute VB_Name = "個人別選択"
Attribute VB_Base = "0{F0647DE2-F885-4453-9983-5BC347861DBD}{CA268610-A1CB-48CC-B417-565267B4DD66}"
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 MyFile As String
Dim i As Integer
Dim n As Integer
Dim nn As Integer
Dim ii As Integer
Dim iii As Integer
Private Sub CheckBox1_Click()
    For i = 0 To ListBox1.ListCount - 1
        ListBox1.Selected(i) = CheckBox1.Value
    Next
End Sub
Private Sub CommandButton1_Click()
    Dim n As Integer
    n = 0
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            n = 1
            Exit For
        End If
    Next
    If n = 0 Then
        MsgBox "リストを選択してください", 16, "個人別一覧表"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Range("D4:T98").FormulaR1C1 = _
        "=IF(R99C="""","""",INDIRECT(""R""&R99C&""C""&ROW()-1,0))"
    Rows(99).ClearContents
    n = 4
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            Cells(99, n).Value = 201 + i
            n = n + 1
            If n = 21 Then
                Application.Calculation = xlCalculationAutomatic
                Application.Calculation = xlCalculationManual
                '20090909 kon
                DoEvents
                ActiveSheet.PrintOut
                '20090909 kon
                DoEvents
                Rows(99).ClearContents
                n = 4
            End If
        End If
    Next
    Application.Calculation = xlCalculationAutomatic
    If n <> 4 Then
    '20090909 kon
    DoEvents
    ActiveSheet.PrintOut
    '20090909 kon
    DoEvents
    End If
    Range("D4:T98").Value = Range("D4:T98").Value
    Rows(99).ClearContents
    Application.ScreenUpdating = True
    Unload Me
End Sub

Private Sub CommandButton2_Click()
If TextBox1.Value = "" Then
MsgBox "検索する文字列を入力してから実行してください。", 16, "個人別一覧表"
Exit Sub
End If
Dim i As Integer
Dim n As Integer
n = 0
For i = 0 To ListBox1.ListCount - 1
    If ListBox1.List(i, 1) Like "*" & TextBox1.Value & "*" Then
    ListBox1.Selected(i) = True
    n = n + 1
    Else
    ListBox1.Selected(i) = False
    End If
Next
If n = 0 Then
MsgBox "「" & TextBox1.Value & "」は見つかりませんでした。", 16, AAA
Else
MsgBox "「" & TextBox1.Value & "」は" & n & "件見つかりました。", 64, AAA
End If

End Sub

Private Sub CommandButton3_Click()
Dim n As Integer
Dim j As Integer
Dim k As Integer
If ListBox2.ListIndex = -1 Then
MsgBox "リストが選択されていません。", 16, AAA
Exit Sub
End If
If OptionButton4.Value = True Then
n = 4
Else
n = 5
End If
j = 0
k = -1
With Workbooks(MyFile).Worksheets("個人情報")
    For i = 0 To ListBox1.ListCount - 1
        If .Cells(6 + i, n).Value = ListBox2.ListIndex + 1 Then
            ListBox1.Selected(i) = True
            j = j + 1
            If k = -1 Then 'トップインデックスに持ってくる
                k = i
            End If
            Else
            ListBox1.Selected(i) = False
        End If
    Next
End With
If j = 0 Then
MsgBox ListBox2.Value & "のデータはありません。", 16, AAA
Else
'MsgBox j & "件選択されました。", 64, AAA
ListBox1.TopIndex = k
End If
End Sub

Private Sub CommandButton4_Click()
    Dim n As Integer
    n = 0
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            n = 1
            Exit For
        End If
    Next
    If n = 0 Then
        MsgBox "リストを選択してください", 16, "個人別一覧表"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Range("D4:T98").FormulaR1C1 = _
        "=IF(R99C="""","""",INDIRECT(""R""&R99C&""C""&ROW()-1,0))"
    Rows(99).ClearContents
    n = 4
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            Cells(99, n).Value = 201 + i
            n = n + 1
            If n = 21 Then Exit For
        End If
    Next
    Application.Calculation = xlCalculationAutomatic
    Range("D4:T98").Value = Range("D4:T98").Value
    Rows(99).ClearContents
    Application.ScreenUpdating = True
    Unload Me

End Sub
Private Sub ListBox2_Click()
CommandButton3_Click
End Sub

Private Sub OptionButton4_Click()
ListBox2.Clear
    With Workbooks(MyFile).Worksheets("基本項目")
        For i = 0 To 100
            If .Cells(5 + i, 20).Value = "" Then Exit Sub
            ListBox2.AddItem .Cells(5 + i, 20).Text
            Next
    End With
End Sub
Private Sub OptionButton5_Click()
ListBox2.Clear
    With Workbooks(MyFile).Worksheets("基本項目")
        For i = 0 To 100
            If .Cells(5 + i, 23).Value = "" Then Exit Sub
            ListBox2.AddItem .Cells(5 + i, 23).Text
            Next
    End With
End Sub

Private Sub UserForm_Initialize()
    Worksheets("賃金台帳").Cells(109, 6).Value = "" '合計印をクリア
    Worksheets("賃金台帳").Range("H109:H110").ClearContents '部門部課印をクリア
    MyFile = Worksheets("読込ファイル").Cells(1, 1).Value
    OptionButton4.Value = True '部門とする
    With Workbooks(MyFile).Worksheets("個人情報")
        For i = 0 To 1000
            If .Cells(6 + i, 2).Value = "" Then Exit Sub
'桁数が多い場合に表示されないため　20160602 kon
'            ListBox1.AddItem .Cells(6 + i, 2).Text
            ListBox1.AddItem .Cells(6 + i, 2).Value
            
            ListBox1.List(i, 1) = .Cells(6 + i, 3).Value
            If .Cells(6 + i, 52).Value <> "" Then '退職者だったら
                ListBox1.List(i, 2) = "×"
                Else
                ListBox1.List(i, 2) = ""
            End If
        Next
    End With

End Sub

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

Attribute VB_Name = "Module2"
Option Explicit

Sub KURIA()
Attribute KURIA.VB_Description = "マクロ記録日 : 2007/4/10  ユーザー名 : Boss"
Attribute KURIA.VB_ProcData.VB_Invoke_Func = " \n14"
    Sheets("賃金台帳").Select
    Cells(110, 15).Value = ""
    Range("E3:E4").Select
    Selection.ClearContents
    Range("C8:C98,R7:R98").Select
    Selection.ClearContents
    Sheets("個人別合計一覧").Select
    Range("D4:T98").Select
    Selection.ClearContents
    Range("C8:C98").Select
    Selection.ClearContents
    Rows("201:319").Select
    Selection.ClearContents
    Selection.EntireRow.Hidden = True
    Rows("200:200").Select
    Selection.EntireRow.Hidden = True
    ActiveWindow.ScrollRow = 1
    Cells(3, 4).ClearContents
    Range("C4").Select
 
    Sheets("賃金台帳").Select
    Range("C6").Select
End Sub
Sub 保存データ()
個人F作成.Show
End Sub
Sub 非表示チェック()
    Dim j As Integer
    For j = 43 To 98
        If Cells(j, 24).Value <> 0 Then
            If Rows(j).Hidden = True Then
                Rows(j).Hidden = False
            End If
        End If
    Next
End Sub
Sub 表示頁印刷()
    If MsgBox("プリンタの準備はいいですか？", 4 + 32, "印刷") <> 6 Then Exit Sub
    '20090909 kon
    DoEvents
    ActiveSheet.PrintOut
    '20090909 kon
    DoEvents
End Sub

Function Zikan(z As Double)

Zikan = (WorksheetFunction.RoundDown(z, 0) + (z - WorksheetFunction.RoundDown(z, 0)) / 0.6) / 24

End Function
Sub パート所得一覧へ() '#28526 20150827 ishikawa
    Workbooks.Open ActiveWorkbook.Path & "\パート所得一覧.xls"
    Worksheets("読込ファイル").Cells(1, 1).Value = ThisWorkbook.Worksheets("読込ファイル").Cells(1, 1).Value
    Worksheets("読込ファイル").Cells(3, 1).Value = ThisWorkbook.Worksheets("読込ファイル").Cells(3, 1).Value
End Sub

Attribute VB_Name = "個人F作成"
Attribute VB_Base = "0{8C9DD622-6237-4C96-A31E-9743631A2188}{C0BA8A5C-3152-48A8-8D9A-856466B95FF9}"
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 MyFile As String
Dim i As Integer
Dim n As Integer

Private Sub CheckBox1_Click()
    For i = 0 To ListBox1.ListCount - 1
        ListBox1.Selected(i) = CheckBox1.Value
    Next
End Sub
Private Sub CommandButton1_Click()
    Dim MyRange As String
    Dim ファイル名 As String
    Dim strPathName As String
    Dim MyFile2 As String
    n = 0
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            n = 1
            Exit For
        End If
    Next
    If n = 0 Then
        MsgBox "リストを選択してください", 16, AAA
        Exit Sub
    End If
    If MsgBox("よろしいですか？", 1 + 32, AAA) <> 1 Then Exit Sub
    Application.Calculation = xlManual
    strPathName = ThisWorkbook.Path & "\" & Worksheets("読込ファイル").Cells(4, 1).Value & "年保存データ"
    If Dir(strPathName, 16) = "" Then
        MkDir strPathName
    End If
    If "検索.xls" <> Dir(strPathName & "\検索.xls") Then '検索読込用のファイル
        FileCopy ThisWorkbook.Path & "\検索.xls", strPathName & "\検索.xls"
    End If
    strPathName = strPathName & "\賃金台帳"
    If Dir(strPathName, 16) = "" Then MkDir strPathName
    
    If Left(MyFile, 10) = "ZennenCopy" Then '前年ファイルでこの操作をおこなったら本ファイルに変換
    MyFile2 = Workbooks(MyFile).Worksheets("MENU").Cells(200, 1).Value '本当のファイル名
    strPathName = strPathName & "\" & Left(MyFile2, Len(MyFile2) - 6)
    Else
    strPathName = strPathName & "\" & Left(MyFile, Len(MyFile) - 6)
    End If
    If Dir(strPathName, 16) = "" Then MkDir strPathName
    
    Application.ReferenceStyle = xlA1
    ActiveSheet.PageSetup.CenterHeader = "&14賃金台帳" '勤怠付き賃金台帳とする
    MyRange = "C3:X100"
    ActiveSheet.PageSetup.PrintArea = "C8:X100"
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Label4.Caption = "作成中・・・"
    Me.Repaint
    Workbooks.Open ActiveWorkbook.Path & "\Dummy.xls"
    ThisWorkbook.Worksheets("賃金台帳").Copy Before:=ActiveWorkbook.Sheets(1) 'シートをコピーする
    
    ファイル名 = ActiveWorkbook.Name
    ActiveSheet.Unprotect
    ActiveSheet.Name = "DATA" 'シートを名前をDATAとする
    Dim wRange As Range '印刷範囲以外のオブジェクトと印刷範囲内のマクロ付のオブジェクトを削除する
    Dim wLeft, wTop, wRight, wBottom
    Dim shapeLeft, shapeTop, shapeRight, shapeBottom
    Dim S As Shape
    With Range(MyRange)
        wTop = .Top
        wLeft = .Left
        wBottom = .Top + .Height
        wRight = .Left + .Width
    End With
    
    For Each S In ActiveSheet.Shapes
        shapeTop = S.Top
        shapeLeft = S.Left
        shapeBottom = S.Top + S.Height
        shapeRight = S.Left + S.Width
        If (wTop <= shapeTop And wLeft <= shapeLeft And _
            wBottom >= shapeBottom And wRight >= shapeRight) And S.OnAction = "" Then
            Else
            S.Delete
        End If
    Next
    Cells.Copy
    Cells.PasteSpecial Paste:=xlValues '数式をすべて値にする
    Range("A6").Select
    Application.CutCopyMode = False
    ThisWorkbook.Activate
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            Label4.Caption = ListBox1.List(i, 1) & "を作成しています・・・"
            Me.Repaint
            Cells(3, 5).Value = ListBox1.List(i, 0)
            Cells(4, 5).Value = ListBox1.List(i, 1)
            Cells(110, 15).Value = i + 6 '個人情報の行番号
            Application.Calculation = xlAutomatic
            Application.Calculation = xlManual
            Workbooks(ファイル名).Activate
            Range(MyRange).Value = ThisWorkbook.Worksheets("賃金台帳").Range(MyRange).Value2
            Rows(1).Hidden = True '1行目はボタンが配置されていたところバランスが悪いので非表示とする
            ActiveWorkbook.SaveAs strPathName & "\" & ListBox1.List(i, 0) & ListBox1.List(i, 1) & ".xls"  '保存する 20140515 titti
            ファイル名 = ActiveWorkbook.Name
            ThisWorkbook.Activate
        End If
    Next
    Workbooks(ファイル名).Close False
    ThisWorkbook.Activate
    Cells(1, 1).Select
    Label4.Caption = ""
    Me.Repaint
    MsgBox strPathName & "に社員名をファイル名として作成しました。", 64, AAA
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    Unload Me
End Sub
Private Sub UserForm_Initialize()
    Cells(109, 6).Value = "" '合計印をクリア
    Range("H109:H110").ClearContents '部門部課印をクリア
    MyFile = Worksheets("読込ファイル").Cells(1, 1).Value
    Dim フォルダ As String
    フォルダ = ThisWorkbook.Path & "\" & Worksheets("読込ファイル").Cells(4, 1).Value & "年保存データ"
    Label10.Caption = フォルダ & "\賃金台帳" & "\" & Left(MyFile, Len(MyFile) - 6)
    Label7.Caption = "全事業所のすべての社員のデータを作成した後、ハードディスクの容量に余裕がない場合は、「" & Worksheets("読込ファイル").Cells(4, 1).Value & "年保存データ」フォルダをＣＤＲ等別のメディアに移動して保存されることをお勧めします。"
    With Workbooks(MyFile).Worksheets("個人情報")
        For i = 0 To 1000
            If .Cells(6 + i, 2).Value = "" Then Exit Sub
'桁数が多い場合に表示されないため　20160602 kon
'            ListBox1.AddItem .Cells(6 + i, 2).Text
            ListBox1.AddItem .Cells(6 + i, 2).Value
            ListBox1.List(i, 1) = .Cells(6 + i, 3).Value
            If .Cells(6 + i, 52).Value <> "" Then '退職者だったら
                ListBox1.List(i, 2) = "×"
                Else
                ListBox1.List(i, 2) = ""
            End If
        Next
    End With
End Sub

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

Attribute VB_Name = "表示項目"
Attribute VB_Base = "0{3C0EFF3F-AF86-4EA0-A777-6C9C75B861F9}{162B5898-60AA-4E5D-8BF5-98E6488D5CD5}"
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 i As Integer
    Dim j As Long
    If MsgBox("この設定を適用しますか？", 4 + 32, "適用") <> 6 Then Exit Sub
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    For i = 8 To 36 '勤怠
        If i >= 23 And i <= 32 Then
        Else
            If i <= 22 Then
            j = 8
            Else
            j = 18
            End If
            If ListBox1.Selected(i - j) <> Rows(i).Hidden Then
                Rows(i).Hidden = ListBox1.Selected(i - j)
                Worksheets("個人別合計一覧").Rows(i).Hidden = ListBox1.Selected(i - j)
            End If
        End If
    Next
    For i = 43 To 68 '支給項目
        If ListBox2.Selected(i - 43) <> Rows(i).Hidden Then
            Rows(i).Hidden = ListBox2.Selected(i - 43)
            Worksheets("個人別合計一覧").Rows(i).Hidden = ListBox2.Selected(i - 43)
        End If
    Next
    For i = 69 To 98 '控除項目
        If ListBox3.Selected(i - 69) <> Rows(i).Hidden Then
            Rows(i).Hidden = ListBox3.Selected(i - 69)
            Worksheets("個人別合計一覧").Rows(i).Hidden = ListBox3.Selected(i - 69)
        End If
    Next
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

Unload Me
End Sub
Private Sub UserForm_Activate()
    Dim i As Integer
    Dim j As Long
    j = 8
    For i = 8 To 36 '勤怠
        If i >= 23 And i <= 32 Then
        Else
        If Cells(i, 3).Value = 0 Then
            ListBox1.AddItem ""
        Else
            ListBox1.AddItem Cells(i, 3).Value
        End If
        If i >= 33 Then j = 18
        ListBox1.Selected(i - j) = Rows(i).Hidden '非表示の列にチェックをいれる
        End If
        
…