Malicious Office (OLE) — malware analysis report

Static analysis result for SHA-256 4496036ae451de2b…

MALICIOUS

Office (OLE)

794.0 KB Created: 2010-05-25 21:45:37 Authoring application: Microsoft Excel First seen: 2018-07-14
MD5: b5790fef7a51dacdbb741a7f457a7e6e SHA-1: 18f084dd054728dc5c250788d680aea8ac5d85ac SHA-256: 4496036ae451de2bfafb8927c6b1b2811f32b0b99565ae53ef694dfea80232ec
142 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1566.001 Spearphishing Attachment

The sample is an Excel file containing VBA macros, which are often used to automate malicious actions. The document body contains Japanese text related to various official forms for social insurance and employment insurance, suggesting a social engineering lure. The presence of CreateProcess and ShellExecute API calls indicates the macro is likely attempting to execute external processes or commands, potentially to download and run a second-stage payload. The benign URL found is likely a red herring or part of the document's legitimate structure.

Heuristics 5

  • Reference to CreateProcess API high SC_STR_CREATEPROCESS
    Reference to CreateProcess API
  • Reference to ShellExecute API high SC_STR_SHELLEXEC
    Reference to ShellExecute API
  • VBA macros detected medium 1 related finding OLE_VBA_MACROS
    Document contains VBA macro code
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        Me.Caption = SName & "の保存データ読込"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    n = 0
  • Embedded URL info EMBEDDED_URL
    One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.
    URL http://schemas.openxmlformats.org/drawingml/2006/main In document text (OLE body)

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 595740 bytes
SHA-256: 384d6dbd12ea198bac05c53321320cb90d66127cc3d670fb28277da1bf6cd42b
Preview script
First 1,000 lines of the extracted script
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 = xlAutomatic

    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 = "Sheet4"
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 = "Sheet11"
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 = "frmPrint"
Attribute VB_Base = "0{EA934A8B-4B3B-4C14-BE89-0449A1CB8890}{D8FAC951-91E9-428C-8E38-DD681A8EDEAB}"
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 ThisWorkbook.Worksheets("登録届201601").Cells(5, 19).Value <> vbNullString Then
        If Application.Run("DaAddin.xla!MNMode", True, False) Then
            If Not Application.Run("DaAddin.xla!CallLogin", PROC_NAME, Workbooks(Worksheets("DATA").Cells(1, 1).Value).Worksheets("会社情報")) Then Exit Sub
        End If
    End If

'印字設定追加
    Dim FSO As Object
    Dim j As Integer
    Dim intFF As Integer            ' FreeFile値
    Dim setString(2) As Double
    Dim strREC As String            ' 読み込んだレコード内容
 

'フォルダを作成
    
    If Dir(ThisWorkbook.Path & "\pdf", vbDirectory) = "" Then
        MkDir (ThisWorkbook.Path & "\pdf")
    End If
    
    If Dir(ThisWorkbook.Path & "\pdf\雇用継続給付", vbDirectory) = "" Then
        MkDir (ThisWorkbook.Path & "\pdf\雇用継続給付")
    End If

    If Dir(hName, vbNormal) = "" Then
        Open hName For Append As #1
            Print #1, IIf(TxtTop.Value = 0, 0, TxtTop.Value / 10) '上余白
            Print #1, IIf(TxtLeft.Value = 0, 0, TxtLeft.Value / 10) '左余白
        Close #1
        
    Else
        Open hName For Output As #1
            Print #1, IIf(TxtTop.Value = 0, 0, TxtTop.Value / 10) '上余白
            Print #1, IIf(TxtLeft.Value = 0, 0, TxtLeft.Value / 10) '左余白
        Close #1
    End If
    
    'YBNO 29510  ito 20151218　201601新様式対応
    'If ActiveSheet.Name = "登録届1230" Or ActiveSheet.Name = "新登録届1230" Then
    If ActiveSheet.Name = "新登録届1230" Or ActiveSheet.Name = "登録届201601" Then
        If Cells(40, 23).Value = "" Then
            MsgBox "被保険者氏名を選択してください。", vbInformation, "雇用継続給付"
            cFg = True
            Unload Me
            Exit Sub
        End If
        
    'データのみ印刷の場合はfalse
        If CheckBox1 = True Then
            pFg = False
        Else
            pFg = True
        End If
        
    'ハローワーク名を印刷する場合はtrue
        hFg = CheckBox2.Value
    '事業所を印刷する場合はtrue
        jFg = CheckBox3.Value
        
        cDat(0) = TextBox1.Value
        cDat(1) = TextBox2.Value
        cDat(2) = TextBox3.Value
        
        Sheets("DATA").Cells(48, 11).Value = TextBox6.Value  '作成日
        Sheets("DATA").Cells(49, 11).Value = ComboBox1.Value '社会保険労務士記入欄
        Sheets("DATA").Cells(50, 11).Value = TextBox7.Value '作成日
        Sheets("DATA").Cells(51, 11).Value = TextBox4.Value '氏名
        Sheets("DATA").Cells(52, 11).Value = TextBox5.Value  '電話番号
        
        '余白設定の読込

        If Dir(hName, vbNormal) <> "" Then
            j = 0
            intFF = FreeFile
            Open hName For Input As intFF
            Do Until EOF(intFF)
                Line Input #intFF, strREC
                setString(j) = IIf(Trim(strREC) = "", 0, strREC)
                j = j + 1
            Loop
            Close #1
        
            Tmargin = setString(0) '上余白
            Lmargin = setString(1) '左余白
        
        End If
        
    ElseIf ActiveSheet.Name = "支給申請1230" Then
        If Cells(24, 20).Value = "" Then
            MsgBox "被保険者氏名を選択してください。", vbInformation, "雇用継続給付"
            cFg = True
            Unload Me
            Exit Sub
        End If
        
    'データのみ印刷は行わないのでデータのみ印刷だけ
        pFg = False
        
    'ハローワーク名を印刷する場合はtrue
        hFg = CheckBox2.Value
    '事業所を印刷する場合はtrue
        jFg = CheckBox3.Value
        
        cDat(0) = TextBox1.Value
        cDat(1) = TextBox2.Value
        cDat(2) = TextBox3.Value
        
        Sheets("DATA").Cells(33, 13).Value = TextBox6.Value  '作成日
        Sheets("DATA").Cells(34, 13).Value = ComboBox1.Value '社会保険労務士記入欄
        Sheets("DATA").Cells(35, 13).Value = TextBox7.Value '作成日
        Sheets("DATA").Cells(36, 13).Value = TextBox4.Value '氏名
        Sheets("DATA").Cells(37, 13).Value = TextBox5.Value  '電話番号
        
        '余白設定の読込
    
    
        If Dir(hName, vbNormal) <> "" Then
            j = 0
            intFF = FreeFile
            Open hName For Input As intFF
            Do Until EOF(intFF)
                Line Input #intFF, strREC
                setString(j) = IIf(Trim(strREC) = "", 0, strREC)
                j = j + 1
            Loop
            Close #1
        
            Tmargin = setString(0) '上余白
            Lmargin = setString(1) '左余白
        End If

    End If
    
    '個人番号があるときにログを作る
    '---------------------------------------------
    If ThisWorkbook.Worksheets("登録届201601").Cells(5, 19).Value <> vbNullString Then
        If Application.Run("DaAddin.xla!MNMode", True, False) Then
            Dim guid As String
            guid = Worksheets("DATA").Cells(10, 1).Value
        
            Dim ComAccount As String
            ComAccount = Application.Run("業務日誌.xlam!GetCompanyData", Workbooks(ThisWorkbook.Worksheets("data").Cells(1, 1).Value))
        
            Application.Run "DaAddin.xla!ProcLogging", ComAccount, PROC_NAME, "印刷", vbNullString, guid, ThisWorkbook.Worksheets("登録届201601").Cells(40, 23).Value, "成功"
        End If
    End If
    '---------------------------------------------
    
    Unload Me
    
End Sub

Private Sub CommandButton2_Click()
    cFg = True
    Unload Me
End Sub

Private Sub CommandButton3_Click()
    Dim fnam As String
    
    If ActiveSheet.Name = "支給申請1230" Then
    '印字設定追加
    'フォルダを作成
        If Dir(ThisWorkbook.Path & "\pdf", vbDirectory) = "" Then
            MkDir (ThisWorkbook.Path & "\pdf")
        End If
        
        If Dir(ThisWorkbook.Path & "\pdf\雇用継続給付", vbDirectory) = "" Then
            MkDir (ThisWorkbook.Path & "\pdf\雇用継続給付")
        End If
    
        If Dir(hName, vbNormal) = "" Then
            Open hName For Append As #1
                Print #1, IIf(TxtTop.Value = 0, 0, TxtTop.Value / 10) '上余白
                Print #1, IIf(TxtLeft.Value = 0, 0, TxtLeft.Value / 10) '左余白
            Close #1
            
        Else
            Open hName For Output As #1
                Print #1, IIf(TxtTop.Value = 0, 0, TxtTop.Value / 10) '上余白
                Print #1, IIf(TxtLeft.Value = 0, 0, TxtLeft.Value / 10) '左余白
            Close #1
        End If

        cDat(0) = TextBox1.Value
        cDat(1) = TextBox2.Value
        cDat(2) = TextBox3.Value
        
        Sheets("DATA").Cells(33, 13).Value = TextBox6.Value  '作成日
        Sheets("DATA").Cells(34, 13).Value = ComboBox1.Value '社会保険労務士記入欄
        Sheets("DATA").Cells(35, 13).Value = TextBox7.Value '作成日
        Sheets("DATA").Cells(36, 13).Value = TextBox4.Value '氏名
        Sheets("DATA").Cells(37, 13).Value = TextBox5.Value  '電話番号
        
        
'        fnam = ThisWorkbook.Path & "\pdf\雇用継続給付\申請裏" & Trim(Cells(30, 39).Value) & Format(Now(), "YYYYMMDDHHMMSS") & ".TDF"
'        If Dir(ThisWorkbook.Path & "\pdf", vbDirectory) = "" Then
'            MkDir (ThisWorkbook.Path & "\pdf")
'
'        End If
'        If Dir(ThisWorkbook.Path & "\pdf\雇用継続給付", vbDirectory) = "" Then
'            MkDir (ThisWorkbook.Path & "\pdf\雇用継続給付")
'        End If


        
        Call pdf作成裏面(CheckBox4.Value)
        
        Dim ShellString As String
        Dim param As String
        param = 3
        'データのみ印刷しか行わないのでfalse
        pFg = False
    
        ShellString = """" & PathCombine(ThisWorkbook.Path, "雇用継続.exe") & """ """ & PathCombine(GetProgramFolder, "雇用継続給付") & """ """ & fnam & """ """ & param & """ """ & pFg & """ """ & Tmargin & """ """ & Lmargin & """"
    
        ExecCmd ShellString
        
    'YBNO 27227  taka 20150302
    'ElseIf ActiveSheet.Name = "登録届1230" Then
    'YBNO 29510  ito 20151226　201601新様式対応
    'ElseIf ActiveSheet.Name = "登録届1230" Then
    ElseIf ActiveSheet.Name = "登録届201601" Then
        OpenPdf ("高年齢雇用継続給付裏201601.pdf")
    
    ElseIf ActiveSheet.Name = "新登録届1230" Then
    
        OpenPdf ("新高年齢雇用継続給付裏.pdf")
        
    End If

End Sub

Private Sub CommandButton4_Click()
    Dim myBookName2 As String
    
    ActiveSheet.Unprotect
    huki = 1
    myBookName2 = ActiveWorkbook.Name
    Application.ScreenUpdating = False
    Workbooks.Open ThisWorkbook.Path & "\第17条付記.xls"
    Workbooks(myBookName2).Activate
    Application.Run "第17条付記.xls!HUKIPDF"

End Sub

Private Sub UserForm_Initialize()
    
    cFg = False
    TextBox1.Text = Format(Now(), "ee")
    TextBox2.Text = Format(Now(), "mm")
    TextBox3.Text = Format(Now(), "dd")
    TextBox4.Text = Workbooks("DaMenu.xls").Worksheets("標準報酬月額").Cells(154, 7).Value
    
    TextBox7.Text = Workbooks("DaMenu.xls").Worksheets("標準報酬月額").Cells(162, 12).Value

    TextBox6.Text = Format(Date, "GE.M.D")
    ComboBox1.AddItem ""
'    ComboBox1.AddItem Format(Date, "GE.M.D")
    ComboBox1.AddItem "提出代行者"
    ComboBox1.AddItem "事務代理者"
    
    '20110512 kon
    ComboBox1.Text = Workbooks("DaMenu.xls").Worksheets("標準報酬月額").Cells(163, 11).Value
    
'    With Workbooks("DaMenu.xls").Worksheets("標準報酬月額")
'        TextBox4.Value = .Cells(154, 7).Value
'        TextBox5.Value = .Cells(155, 7).Value
'    End With
    
    CheckBox2.Value = True
    CheckBox3.Value = True
    'YBNO 29510  ito 20151224　201601新様式対応
    'If ActiveSheet.Name = "登録届1230" Then
    If ActiveSheet.Name = "新登録届1230" Or ActiveSheet.Name = "登録届201601" Then
        CheckBox1.Enabled = True
        CheckBox4.Enabled = False
    ElseIf ActiveSheet.Name = "支給申請1230" Then
        CheckBox1.Enabled = False
        CheckBox4.Enabled = True
        CommandButton4.Visible = False
    End If
    TextBox4.Value = Workbooks("DaMenu.xls").Worksheets("標準報酬月額").Cells(154, 7).Value
    TextBox5.Value = Workbooks("DaMenu.xls").Worksheets("標準報酬月額").Cells(155, 7).Value

'印字設定追加
    '余白設定のファイル名
    'YBNO 29510  ito 20151224　201601新様式対応
    'If ActiveSheet.Name = "登録届1230" Then
    If ActiveSheet.Name = "新登録届1230" Or ActiveSheet.Name = "登録届201601" Then
        hName = ThisWorkbook.Path & "\pdf\雇用継続給付\touroku.txt"
    Else
        hName = ThisWorkbook.Path & "\pdf\雇用継続給付\sinsei.txt"
    End If
    
    Dim j As Integer
    Dim intFF As Integer            ' FreeFile値
    Dim setString(2) As Double
    Dim strREC As String            ' 読み込んだレコード内容
    
    For j = 0 To 9
        TxtTop.AddItem j
        TxtLeft.AddItem j
    Next j
    
    If Dir(hName, vbNormal) <> "" Then
        j = 0
        intFF = FreeFile
        Open hName For Input As intFF
        Do Until EOF(intFF)
            Line Input #intFF, strREC
            setString(j) = IIf(Trim(strREC) = "", 0, strREC)
            j = j + 1
        Loop
        Close #1
    
        TxtTop.Value = setString(0) * 10 '上余白
        TxtLeft.Value = setString(1) * 10 '左余白
    Else
        TxtTop.Value = 0 '上余白
        TxtLeft.Value = 0 '左余白
    End If


End Sub
Sub pdf作成裏面(prnt As Boolean)
    Dim fName As String
    
    '必要データ作成
'    Dim TextFilename As String
'    TextFilename = fn
    
    Dim SheetName As String
    
    SheetName = "支給申請1230"
    
    fName = ThisWorkbook.Path & "\pdf\雇用継続給付\" & Trim(Cells(24, 20).Value) & Format(Now(), "YYYYMMDDHHMMSS") & ".TDF"
    If Dir(ThisWorkbook.Path & "\pdf", vbDirectory) = "" Then
        MkDir (ThisWorkbook.Path & "\pdf")
    End If
    If Dir(ThisWorkbook.Path & "\pdf\雇用継続給付", vbDirectory) = "" Then
        MkDir (ThisWorkbook.Path & "\pdf\雇用継続給付")
    End If
'    If Dir(ThisWorkbook.Path & "\pdf\雇用継続給付\" & Cells(33, 20).Value, vbDirectory) = "" Then
'        MkDir (ThisWorkbook.Path & "\pdf\雇用継続給付\" & Cells(33, 20).Value)
'    End If
    
    'パスワードは利用しないので空欄
    Call PDF申請書作成裏(fName, prnt)
    
End Sub



Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
'        MsgBox "キャンセルボタンでキャンセルしてください。", vbInformation, "雇用保険資格取得"
        Cancel = True
    End If

End Sub

Attribute VB_Name = "新保存F"
Attribute VB_Base = "0{9A73974B-9A6D-461F-A0EF-D521E3530760}{D5F03A15-5469-40AB-BE95-4480E8A83C2C}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False

'YBNO 29510/18377  ito 20151221　201601新様式対応/保存方法変更
Option Explicit

Private Sub CommandButton1_Click()
    Dim da As String
    Dim Fda As String
    Dim Fdb As String
    Dim MyP As String
    Dim s As Shape
    Dim aw As String
    aw = ActiveWorkbook.Name
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    da = Worksheets("DATA").Cells(1, 1).Value
    Fda = Left(da, Len(da) - 4) 'daをフォルダ名にする
    Fdb = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) '処理ファイルをフォルダ名にする
    '\DaProcess\台帳名\処理ファイル名\シート名　フォルダに保存する
    If Dir(ThisWorkbook.Path & "\Da保存", 16) = "" Then MkDir ThisWorkbook.Path & "\Da保存"
    If Dir(ThisWorkbook.Path & "\Da保存\" & Fda, 16) = "" Then MkDir ThisWorkbook.Path & "\Da保存\" & Fda
    If Dir(ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb, 16) = "" Then MkDir ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb
    If Dir(ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\" & ActiveSheet.Name, 16) = "" Then MkDir ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\" & ActiveSheet.Name
    MyP = ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\" & ActiveSheet.Name & "\" & TextBox1.Value & ".xls"
    Dim 保存ファイル名 As String
    保存ファイル名 = TextBox1.Value & ".xls"
    If 保存ファイル名 = Dir(MyP) Then     'すでにあるかチェック
        If MsgBox("この保存ファイルはすでに存在します。上書きしますか？", 1 + 48, AAA) <> 1 Then
            MsgBox "処理を中止します。", 64, AAA
            Exit Sub
        End If
    End If
    
    Application.Calculation = xlCalculationManual
    Dim fName As String
    fName = ActiveSheet.Name
    If ActiveSheet.Name = "証明書" Then  '証明書
        ActiveSheet.Copy
        ActiveSheet.Unprotect
        Cells.Copy
        Cells.PasteSpecial Paste:=xlPasteValues
        Application.Calculation = xlCalculationAutomatic
        DoEvents
        For Each s In ActiveSheet.Shapes
            On Error Resume Next
            If s.Type = msoFormControl Or s.OnAction <> "" Or s.Top < 40 Then 'マクロ付きと上の方のオブジェクトとフォームコントロール
            On Error GoTo 0
                s.Delete
            End If
        Next
    Else  '登録届・支給申請
        If ActiveSheet.Name = "支給申請1230" Then  '支給申請
            申請登録1230
        Else '登録届
            登録1230
        End If
        ThisWorkbook.Worksheets("DATA").Activate
        ActiveSheet.Copy
        ActiveSheet.Unprotect
        Cells.Copy
        Cells.PasteSpecial Paste:=xlPasteValues
        Range("K57").ClearContents  '保存時マイナンバークリア
        Application.Calculation = xlCalculationAutomatic
    End If
    
    Application.CutCopyMode = False
    Cells(1, 1).Select
    If CSng(Application.Version) > 11 = True Then
        ActiveWorkbook.SaveAs MyP, FileFormat:=56 '2007以上
    Else
        ActiveWorkbook.SaveAs MyP '2003
    End If
    ActiveWorkbook.Close False
      
    Workbooks(aw).Worksheets(fName).Activate
    Cells(1, 1).Select
    MsgBox "保存しました。", 64, "保存"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    If ActiveSheet.Name = "証明書" Then
        TextBox1.Value = Cells(3, 25).Value & " " & Format(Date, "YYYYMMDD作成")
    ElseIf ActiveSheet.Name = "支給申請1230" Then
        TextBox1.Value = Cells(24, 20).Value & " " & Format(Now, "YYYYMMDD作成")
    Else  '登録届
        TextBox1.Value = Cells(40, 23).Value & " " & Format(Now, "YYYYMMDD作成")
    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 = "Sheet16"
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{EDB1CB86-9AC3-4C33-A5B7-BBB24F9CBEE0}{CE2F75EC-802C-44F9-8976-72B1C88E9B2F}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False

'YBNO 29510/18377  ito 20151221　201601新様式対応/保存方法変更
Option Explicit
Dim MyP As String
Dim MyCheck As Boolean
    
Private Sub CheckBox1_Change()
    Dim da As String
    Dim Fda As String
    Dim Fdb As String
    Dim Fn As String
    Dim FSO As Object
    Dim SName As String
    Dim n As Long
    
    If CheckBox1.Value = True Then
        SName = "新登録届1230"
    Else
        SName = ActiveSheet.Name
    End If
    
    Me.Caption = SName & "の保存データ読込"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    n = 0
    da = Worksheets("DATA").Cells(1, 1).Value
    Fda = Left(da, Len(da) - 4)
    Fdb = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
    MyP = ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\" & SName
    Fn = Dir(MyP & "\*.*")
    ListBox1.Clear
    Do While Fn <> ""
        With ListBox1
            .AddItem Left(Fn, Len(Fn) - 4)
            .List(n, 1) = FSO.GetFile(MyP & "\" & Fn).DateLastModified '最終更新日時
            n = n + 1
            Fn = Dir()
        End With
    Loop
    Set FSO = Nothing
End Sub

Private Sub CommandButton1_Click()
    Dim i As Long
    Dim n As Long
    Dim s As String
    Dim fName As String
    Dim Wh As Worksheet
    fName = ActiveSheet.Name
    
    If ListBox1.ListIndex = -1 Then
        MsgBox "ファイルが選択されていません", 16, "読込"
        Exit Sub
    End If
    If MsgBox("保存データをこのファイルに読み込みます。処理中のデータは上書きされます。よろしいですか？", 1 + 32, "読込") <> 1 Then Exit Sub
    
    Application.ScreenUpdating = False
    
    If fName = "証明書" Then
        Workbooks.Open MyP & "\" & ListBox1.Value & ".xls"
        Set Wh = ThisWorkbook.ActiveSheet
            Wh.Range(Wh.Cells(1, 1), Wh.Cells(100, 40)).Value = Range(Cells(1, 1), Cells(100, 40)).Value
            Wh.Range("F16").FormulaR1C1 = "=MONTH(R3C50+1)"
            Wh.Range("H16").FormulaR1C1 = "=DAY(R3C50+1)"
            Wh.Range("B17:B29").FormulaR1C1 = "=IF(COUNT(RC[9])=1,MONTH(RC[48]),"""")"
            Wh.Range("D17:D29").FormulaR1C1 = "=IF(COUNT(RC[7])=1,DAY(RC[46]),"""")"
            Wh.Range("F18:F29").FormulaR1C1 = "=IF(COUNT(RC[5])=1,MONTH(RC[45]),"""")"
            Wh.Range("H18:I29").FormulaR1C1 = "=IF(COUNT(RC[3])=1,DAY(RC[43]),"""")"
            Wh.Range("N17:N29").FormulaR1C1 = "=IF(COUNT(RC[8])=1,MONTH(RC[38]),"""")"
            Wh.Range("P17:P29").FormulaR1C1 = "=IF(COUNT(RC[6])=1,DAY(RC[36]),"""")"
            Wh.Range("R18:R29").FormulaR1C1 = "=IF(COUNT(RC[4])=1,MONTH(RC[35]),"""")"
            Wh.Range("T18:T29").FormulaR1C1 = "=IF(COUNT(RC[2])=1,DAY(RC[33]),"""")"
        Set Wh = Nothing
    Else
        ThisWorkbook.Worksheets(fName).Unprotect
        '数式が消えていた時のため数式を戻す　50列目以降に同じ書式を用意
        Columns("AX:CF").Copy
        Columns("B:AJ").Select
        Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        ThisWorkbook.Worksheets(fName).Protect
            
        Workbooks.Open MyP & "\" & ListBox1.Value & ".xls"
        Set Wh = ThisWorkbook.Sheets("DATA")
            Wh.Range(Wh.Cells(1, 10), Wh.Cells(100, 15)).Value = Range(Cells(1, 10), Cells(100, 15)).Value
            Wh.Range(Wh.Cells(10, 1), Wh.Cells(14, 1)).Value = Range(Cells(10, 1), Cells(14, 1)).Value
        Set Wh = Nothing
    End If
    
    Workbooks(ListBox1.Value & ".xls").Close False
    ThisWorkbook.Activate
    Sheets(fName).Select
    
    Unload Me
    MsgBox "OK", 64, AAA
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
End Sub

Private Sub CommandButton2_Click()
    If ListBox1.ListIndex = -1 Then
        MsgBox "ファイルが選択されていません", 16, AAA
        Exit Sub
    End If
    If MsgBox(ListBox1.Value & "を削除してもいいですか？", 1 + 32, "削除") <> 1 Then Exit Sub
    Kill MyP & "\" & ListBox1.Value & ".xls"
    ListBox1.RemoveItem ListBox1.ListIndex
    MsgBox "削除しました", 64, AAA
End Sub

Private Sub CommandButton3_Click()
    Dim i As Integer
    If Trim(TextBox1.Value) = "" Then
        MsgBox "検索する文字列を入力して下さい。", 16, AAA
        Exit Sub
    End If
    Dim n As Integer
    If MyCheck = False Then
        n = 0
    Else
        n = ListBox1.ListIndex + 1 '現在選択されている位置の次のところ
    End If
    For i = n To ListBox1.ListCount - 1
        If ListBox1.List(i, 0) Like "*" & TextBox1.Value & "*" Then
            ListBox1.Selected(i) = True
            MyCheck = True
            Exit Sub
        End If
    Next
    MsgBox "見つかりません。", 64, AAA
End Sub

Private Sub CommandButton4_Click()
    Unload Me
    Da保存読込へ  '旧保存データ
End Sub

Private Sub TextBox1_Change()
    MyCheck = False
End Sub

Private Sub UserForm_Initialize()
    If ActiveSheet.Name = "支給申請1230" Or ActiveSheet.Name = "新登録届1230" Or ActiveSheet.Name = "証明書" Then
        CommandButton4.Visible = True
    ElseIf ActiveSheet.Name = "登録届201601" Then
        CheckBox1.Visible = True
        Label2.Visible = True
    End If
    Me.Caption = ActiveSheet.Name & "の保存データ読込"
    Dim da As String
    Dim Fda As String
    Dim Fdb As String
    Dim Fn As String
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim n As Long
    n = 0
    da = Worksheets("DATA").Cells(1, 1).Value
    Fda = Left(da, Len(da) - 4)
    Fdb = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
    MyP = ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\" & ActiveSheet.Name
    Fn = Dir(MyP & "\*.*")
    Do While Fn <> ""
        With ListBox1
            .AddItem Left(Fn, Len(Fn) - 4)
            .List(n, 1) = FSO.GetFile(MyP & "\" & Fn).DateLastModified '最終更新日時
            n = n + 1
            Fn = Dir()
        End With
    Loop
    Set FSO = Nothing
End Sub

Attribute VB_Name = "Sheet7"
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{72F1A17C-2F17-4297-8F09-98293DC9EDE4}{4F3A1F07-F299-43E7-9979-EDE256F0F71B}"
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 Button閉じる_Click()

  Cells(4, 2).Value = Worksheets("DATA").Cells(38, 2).Value
  
  If TextBox1.Value = "" Then
  MsgBox "60歳到達賃金が入力されていません。"
  Else
   If OptionButton1.Value = True Then
     Range("U14:U19").Value = Range("W14:W19").Value '新率
   Else
     Range("U14:U19").Value = Range("V14:V19").Value '旧率
    End If

  Cells(6, 2).Value = ListBox1.Text
Cells(17, 3).Value = TextBox1.Value
Cells(19, 3).Value = Int(TextBox1.Value * Cells(15, 21).Value)
Cells(10, 21).Value = TextBox8.Value
Cells(11, 21).Value = TextBox9.Value
Cells(7, 29).Value = ListBox1.ListIndex
Unload Me
End If
End Sub


Private Sub ListBox1_Click()
Label37.Caption = ListBox1.Text
End Sub

Private Sub UserForm_Activate()
MyFile = Worksheets("DATA").Cells(1, 1).Value
With Workbooks(MyFile).Worksheets("個人情報")
n = 0
For i = 6 To .Cells(10000, 2).End(xlUp).Row
'取得日があって離職日がないデータ
If IsDate(.Cells(i, 29).Value) = True And IsDate(.Cells(i, 30).Value) = False Then

ListBox1.AddItem i '行番号
ListBox1.List(n, 1) = .Cells(i, 5).Value & " " & .Cells(i, 6).Value
n = n + 1
End If
Next
End With
   TextBox1.Value = Cells(17, 3).Value
   
   TextBox8.Value = Cells(10, 21).Value
   TextBox9.Value = Cells(11, 21).Value
On Error Resume Next
ListBox1.ListIndex = Cells(7, 29).Value


End Sub
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If KeyAscii = 8 Or KeyAscii = 45 Then Exit Sub
    If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0
End Sub
Private Sub TextBox4_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If KeyAscii = 8 Or KeyAscii = 45 Then Exit Sub
    If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0
End Sub
Private Sub TextBox7_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If KeyAscii = 8 Or KeyAscii = 45 Then Exit Sub
    If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0
End Sub
Private Sub TextBox8_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If KeyAscii = 8 Or KeyAscii = 45 Then Exit Sub
    If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0
End Sub
Private Sub TextBox9_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If KeyAscii = 8 Or KeyAscii = 45 Then Exit Sub
    If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0
End Sub


Attribute VB_Name = "フォーム60歳登録"
Attribute VB_Base = "0{02F1412D-8E5C-4C3F-A584-5F76FAEEAB90}{290FF122-6324-4DBB-8F46-54B4B94C2A56}"
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
Private Sub Commandクリア_Click()
'Text被保険者番号.Value = ""
'Text申請者氏名.Value = ""
'Textフリガナ.Value = ""
Cells(8, 4).Value = ""
Cells(10, 4).Value = ""
Cells(13, 15).Value = ""
Cells(15, 15).Value = ""
Cells(19, 15).Value = ""
Cells(20, 15).Value = ""
Cells(23, 9).Value = ""
Cells(24, 9).Value = ""
Cells(26, 10).Value = ""
'Text〒.Value = ""
'Text電話.Value = ""
'Text住所.Value = ""
'ComboBox2.Value = ""
'ComboBox3.Value = ""
'ComboBox4.Value = ""
ComboBox8.Value = ""
ComboBox9.Value = ""
ComboBox10.Value = ""
'ComboBox11.Value = ""
'ComboBox12.Value = ""
'ComboBox13.Value = ""


End Sub


Private Sub CheckBox3_Click()

    Dim n As Long
    Dim i As Long

    With Workbooks(MyFile).Worksheets("個人情報")
        ListBox1.Clear
        n = 0
        For i = 6 To .Cells(10000, 2).End(xlUp).Row
            '取得日があって離職日がないデータ
            
            If IsDate(.Cells(i, 29).Value) = True And IsDate(.Cells(i, 30).Value) = False And IsDate(.Cells(i, 13).Value) = True Then
                If CheckBox3.Value = True Then
                    If Int((Date - .Cells(i, 13).Value) / 365.25) >= 59 Then
                        ListBox1.AddItem i '行番号
                        ListBox1.List(n, 1) = .Cells(i, 5).Value & " " & .Cells(i, 6).Value
                        ListBox1.List(n, 2) = Int((Date - .Cells(i, 13).Value) / 365.25)
                        n = n + 1
                    End If
                Else
                    ListBox1.AddItem i '行番号
                    ListBox1.List(n, 1) = .Cells(i, 5).Value & " " & .Cells(i, 6).Value
                    ListBox1.List(n, 2) = Int((Date - .Cells(i, 13).Value) / 365.25)
                    n = n + 1
                End If
            End If
        Next
    End With

End Sub

Private Sub Command実行_Click()

Dim SH As Object
Dim KZ As Object
Set SH = ThisWorkbook.Worksheets("証明書")
Set KZ = Worksheets("DATA")
With Workbooks(MyFile).Worksheets("個人情報")

If ListBox1.ListIndex = -1 Then
MsgBox "リストから被保険者を選択してください。"
Else
Application.ScreenUpdating = False

Cells(8, 32).Value = .Cells(ListBox1.Value, 26).Value '雇用保険番号


Cells(10, 32).Value = KZ.Cells(66, 2).Value    '事業所番号
Cells(25, 15).Value = KZ.Cells(38, 2).Value '事業所名
If CheckBox2.Value = True Then
Cells(24, 15).Value = KZ.Cells(107, 2).Value '所在地
Else
Cells(24, 15).Value = KZ.Cells(40, 2).Value '所在地
End If
Cells(26, 15).Value = KZ.Cells(41, 2).Value & " " & KZ.Cells(42, 2).Value   '代表者

Cells(8, 35).Value = .Cells(ListBox1.Value, 29).Value '資格取得年月日
Cells(8, 45).Value = .Cells(ListBox1.Value, 13).Value '生年月日

Cells(10, 17).Value = TextBox12.Value
Cells(13, 32).Value = TextBox6.Value
Cells(15, 32).Value = TextBox7.Value
Cells(17, 32).Value = TextBox8.Value
Cells(13, 33).Value = Text1.Value
Cells(15, 33).Value = TextBox2.Value
Cells(17, 33).Value = TextBox3.Value
Cells(13, 34).Value = TextBox9.Value
Cells(15, 34).Value = TextBox10.Value
Cells(17, 34).Value = TextBox11.Value
Cells(21, 3).Value = Text11.Value
Cells(21, 11).Value = Text12.Value
Cells(21, 19).Value = Text13.Value
Cells(7, 30).Value = CheckBox1.Value




SH.Cells(2, 40).Value = .Cells(ListBox1.Value, 2).Value 'No

SH.Cells(2, 6).Value = Mid(Cells(8, 32).Text, 1, 4)    '被保険者番号
…

Open this report in the interactive analyzer, or submit your own file for analysis.