Malicious Office (OLE) — malware analysis report

Static analysis result for SHA-256 558ceb0a37f74fc7…

MALICIOUS

Office (OLE)

1.09 MB Created: 2010-02-25 05:24:59 Authoring application: Microsoft Excel First seen: 2018-06-21
MD5: 519155dd0361ea13bcd21b9d043005ed SHA-1: 112da7fa233d41501597c9efc9644d61cfcb1496 SHA-256: 558ceb0a37f74fc7fecef3ce09db84b5df43781376a92771776a9823b01157bd
142 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1566.001 Spearphishing Attachment T1204.002 Malicious File T1059.001 PowerShell

The sample is an Excel file containing VBA macros. The macros contain a function 'go_manual' which constructs a URL to a PDF document. The document also contains heuristics indicating the use of ShellExecute and a lure to copy/paste content into a shell, suggesting an attempt to execute arbitrary commands. The presence of VBA macros and the lure to execute commands point towards a macro-based downloader.

Heuristics 5

  • Reference to ShellExecute API high SC_STR_SHELLEXEC
    Reference to ShellExecute API
  • Clipboard command execution lure high SE_CLIPBOARD_COMMAND_LURE
    Document tells the user to copy or paste clipboard content into Run, PowerShell, cmd, or another shell-like execution context
  • 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
    '    myFso.CopyFile ThisWorkbook.Path & "\建設業\専用用紙\" & ファイル名, strPathName & "\" & Mid(ファイル名, 4, Len(ファイル名))
    Set myFso = CreateObject("Scripting.FileSystemObject")
  • 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://www.cells.co.jp/daityo-s/wp-content/uploads/manual/kensetu.pdf In document text (OLE body)
    • http://www.cells.co.jpIn document text (OLE body)
    • http://www.nga.gr.jp/tijifile/filetop.htmlIn document text (OLE body)
    • http://www.lasdec.nippon-net.ne.jp/com/addr/jyu_top.htmIn document text (OLE body)
    • http://ns.adobe.com/xap/1.0/In document text (OLE body)
    • http://www.w3.org/1999/02/22-rdf-syntax-ns#In document text (OLE body)
    • http://ns.adobe.com/iX/1.0/In document text (OLE body)
    • http://ns.adobe.com/xap/1.0/mm/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) 216549 bytes
SHA-256: 15216eb44c4ce0f9b104ee6172339b557f223afaaac25a4b7e361267596942e1
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


Attribute VB_Name = "Module3"
Option Explicit

Private Sub マクロ(MacroName As String)
  Application.Run ThisWorkbook.Path & "!" & MacroName

End Sub
Sub 財務諸表関連()
    マクロ ("財務諸表関連")
End Sub
Sub 印刷()
マクロ ("印刷")
End Sub
Sub 印刷1()
マクロ ("印刷1")
End Sub
Sub 会社情報へ()
    会社情報.Show
End Sub
Sub 許可番号へ()
    許可番号.Show
End Sub
Sub Font切替()
    Call Font切替
End Sub
Sub 許可申請入力へ()
    許可申請入力.Show
End Sub
'Sub 専任技術者証明書へ()
Sub senninSyomei()
    
    専任技術者証明書.Show
End Sub
Sub 国家資格Fへ()
    国家資格F.Show
End Sub
Sub 管理責任者Fへ()
    管理責任者.Show
End Sub
Sub 変更届Fへ()
    変更届F.Show
End Sub
'Sub マニュアルへ()
'    Application.Run "DaAddin.xla!OpenManual"
'End Sub
Sub go_manual() '#32109 20160606 ishikawa
    Dim url As String
    url = "http://www.cells.co.jp/daityo-s/wp-content/uploads/manual/kensetu.pdf"
    Application.Run "DaAddin.xla!WebManual", url
End Sub
Sub 数式整合へ()
''    Call 数式の整合
End Sub
Sub マイナス表示切捨()
    Call マイナス表示切捨
End Sub
Sub 行調整()
    Call 行調整
End Sub
Sub 税込みから税抜きへ()
    Call 税込みから税抜きへ
End Sub
Sub 印刷提出票()
    Call 印刷提出票
End Sub
Sub msJigyosyoR()

    マクロ ("マスター事業所データ読込")
End Sub
Sub マスター事業所データ読込2()
マクロ ("マスター事業所データ読込2")
End Sub
Sub msKanrisekinin()
    If MsgBox("マスターから事業所データを適用しますか？", 1 + 32, "適用") <> 1 Then Exit Sub
    With Workbooks("DATA.xls").Worksheets("DATA")
         Cells(16, 92).Value = .Cells(6, 2).Value '所在地
        Cells(17, 92).Value = .Cells(7, 2).Value '会社名
        Cells(18, 92).Value = .Cells(8, 2).Value & " 　" & .Cells(9, 2).Value '代表者
    End With
End Sub
Sub マスター許可番号データ読込()
マクロ ("マスター許可番号データ読込")
End Sub
Sub 行政書士印()
マクロ ("行政書士印")
End Sub
Sub クリア工事経歴1()
マクロ ("クリア工事経歴1")
End Sub
Sub 代表者の読込()
マクロ ("代表者の読込")
End Sub
Sub 二面へ()
マクロ ("二面へ")
End Sub
Sub 別表からの氏名役職名の読込2()
'マクロ ("別表からの氏名の読込")
    Dim i, n As Integer
    Dim myPath As String

    If MsgBox("別表の役員の氏名・ﾌﾘｶﾞﾅ・生年月日を読み込みます。", 1 + 32, "読込") <> 1 Then Exit Sub
    
    myPath = PathCombine(ThisWorkbook.Path, "建設業")
    myPath = PathCombine(myPath, ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    
    Workbooks.Open myPath & "\役員の一覧表.xls"
    
    Workbooks("役員氏名.xls").Worksheets("役員氏名").Activate
    With Workbooks("役員の一覧表.xls").Worksheets("役員の一覧表")
        n = 10
        For i = 11 To 25 Step 2
            Cells(n, 3).Value = .Cells(i, 2).Value
            Cells(n + 1, 2).Value = .Cells(i + 1, 2).Value
            
            Cells(n, 6).Value = Format(.Cells(i, 5).Value, "e")
            Cells(n, 8).Value = Format(.Cells(i, 5).Value, "mm")
            Cells(n, 10).Value = Format(.Cells(i, 5).Value, "dd")
            
            Cells(n, 13).Value = .Cells(i + 16, 2).Value
            Cells(n + 1, 12).Value = .Cells(i + 17, 2).Value
            
            Cells(n, 16).Value = Format(.Cells(i + 16, 5).Value, "e")
            Cells(n, 18).Value = Format(.Cells(i + 16, 5).Value, "mm")
            Cells(n, 20).Value = Format(.Cells(i + 16, 5).Value, "dd")
            n = n + 3
        Next
        
    End With
    With Workbooks("DATA.xls").Worksheets("DATA")
        Cells(6, 3).Value = .Cells(66, 2).Value
        Cells(7, 3).Value = .Cells(7, 2).Value
        Cells(7, 13).Value = .Cells(21, 2).Value & "-" & .Cells(22, 2).Value & " 第 " & .Cells(23, 2).Value & " 号"
    End With
    Workbooks("役員の一覧表.xls").Close
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "読込ました。", vbInformation, "読込"


End Sub

Sub 分類Fへ()
マクロ ("分類Fへ")
End Sub
Sub 工事種類へ()
マクロ ("工事種類へ")
End Sub

Sub 資格へ()
マクロ ("資格へ")
End Sub
Sub zoUp()
On Error Resume Next
ActiveWindow.Zoom = ActiveWindow.Zoom + 5
End Sub
Sub zmDown()
On Error Resume Next
ActiveWindow.Zoom = ActiveWindow.Zoom - 5
End Sub
Sub 裏表紙へ()
    シートへ ("裏表紙")
End Sub
Sub 表紙2へ()
    シートへ ("表紙")
End Sub
Sub 表紙1へ()
    シートへ ("終了届表紙")
End Sub

Sub 工事施工金額へ()
    シートへ ("施工金額")
End Sub
Sub 経営業務の管理責任者の略歴所へ()
    シートへ ("経営業務の管理責任者の略歴書")
End Sub
Sub 専任技術者一覧表へ()
    シートへ ("専任技術者一覧表")
End Sub
Sub 標準へ()
    シートへ ("事業報告標準")
End Sub
Sub 簡易へ()
    シートへ ("事業報告簡易")
End Sub
Sub 財務諸表表紙へ()
    シートへ ("財務諸表法人")
End Sub
Sub 貸借対照表1へ()
    zaimuHo ("１５（１）")
End Sub
Sub 貸借対照表2へ()
    zaimuHo ("１５（２）")
End Sub
Sub 貸借対照表3へ()
    zaimuHo ("１５（３）")
End Sub
Sub 貸借対照表4へ()
    zaimuHo ("１６（４）")
End Sub
Sub 貸借対照表5へ()
    zaimuHo ("１６（５）")
End Sub
Sub 貸借対照表6へ()
    zaimuHo ("１７（６）")
End Sub
Sub 貸借対照表7へ()
    zaimuHo ("１７－２（７）")
End Sub
Sub 貸借対照表8へ()
    zaimuHo ("１７－２（８）")
End Sub

Sub 財務諸表表紙個人へ()
    シートへ ("財務諸表個人")
End Sub
Sub 個人貸借対照表1へ()
    zaimuKo ("１８（１）")
End Sub
Sub 個人貸借対照表2へ()
    zaimuKo ("１８（２）")
End Sub
Sub 個人貸借対照表3へ()
    zaimuKo ("１９（３）")
End Sub


Sub 予備届出書へ()
    シートへ ("予備届出書")
End Sub
Sub 予備廃業届へ()
    シートへ ("予備廃業届")
End Sub
Sub 予備始末書へ()
    シートへ ("予備始末書")
End Sub
Sub 予備付属明細書へ()
    シートへ ("予備付属明細書")
End Sub

Sub アップ非表示()
    ActiveSheet.Shapes("アップ").Visible = False
End Sub
Sub アップ表示()
    ActiveSheet.Shapes("アップ").Visible = True
End Sub

Sub コンバート()
    アップ非表示
    マクロ ("コンバートへ")
End Sub
Sub 営業所一覧()
    マクロ ("営業所一覧へ")
End Sub

Sub シートへ(シート)
    Dim myPath As String
    Dim wb As Workbook

    Application.ScreenUpdating = False
    myPath = PathCombine(ThisWorkbook.Path, "建設業")
    myPath = PathCombine(myPath, ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value)
   
    Application.ScreenUpdating = False
    
    For Each wb In Workbooks
        If wb.Name = ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value Then
            wb.Activate
            
            Exit Sub
        End If
    Next
    
    Application.DisplayAlerts = False
    Workbooks.Open PathCombine(myPath, シート & ".xls"), Notify:=False
    Application.DisplayAlerts = True
    

    
    '工事施工金額の場合は法人の財務諸表を開く
    If シート = "施工金額" Then
        Application.DisplayAlerts = False
        
        Application.EnableEvents = False
        Workbooks.Open PathCombine(myPath, "財務諸表H.xls"), Notify:=False
        Application.EnableEvents = True
        Workbooks(シート & ".xls").Sheets(シート).Cells(1, 27).Value = Sheets("１６（４）").Cells(12, 49).Value
        Application.EnableEvents = False
        Workbooks("財務諸表H.xls").Close
        
        Workbooks.Open PathCombine(myPath, "財務諸表K.xls"), Notify:=False
        Application.EnableEvents = True
        Workbooks(シート & ".xls").Sheets(シート).Cells(1, 26).Value = Sheets("１９（３）").Cells(12, 49).Value
        Application.EnableEvents = False
        Workbooks("財務諸表K.xls").Close
        Application.EnableEvents = True
        
        Application.DisplayAlerts = True
    
    
    End If
    
    '入力規則表示
    Select Case シート
    Case "工事経歴"
        Call SetList(3, "D7")
    Case "施工金額"
        Call SetList(3, "L7")
        Call SetList(3, "N7")
        Call SetList(3, "P7")
        Call SetList(3, "R7")
    
        Call SetList(3, "L48")
        Call SetList(3, "N48")
        Call SetList(3, "P48")
        Call SetList(3, "R48")
    
        Call SetList(3, "L89")
        Call SetList(3, "N89")
        Call SetList(3, "P89")
        Call SetList(3, "R89")

    
    End Select

    Call kSyori
    
    Sheets(シート).Select
    Cells(1, 180).Value = "[DATA.xls]DATA!"
'    Cells(1, 180).Font.ThemeColor = xlThemeColorDark1
    Cells(1, 1).Select
    
    
    
    
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
    Application.ScreenUpdating = True

End Sub
Sub 専用シートへ(シート)
    Dim MyB As String
    Dim strPathName As String

    MyB = ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value
    strPathName = ThisWorkbook.Path & "\建設業\" & MyB
    strPathName = strPathName & "\県用紙\"
'20140502 kon 25136
'    Application.DisplayAlerts = False
'    Workbooks.Open PathCombine(strPathName, シート & ".xls"), Notify:=False
'    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    DoEvents
    Workbooks.Open PathCombine(strPathName, シート & ".xls"), Notify:=False
    DoEvents

    Sheets(シート).Select
    Cells(1, 180).Value = "[DATA.xls]DATA!"
'    Cells(1, 180).Font.ThemeColor = xlThemeColorDark1
    Cells(1, 1).Select
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
    Application.ScreenUpdating = True

End Sub
Sub zaimuHo(fNam As String)
    Dim AA As Variant
    Dim i As Integer
    Dim n As Integer
    Dim file_name As Object
    Dim myPath As String
    
    AA = Array("１５（１）", "１５（２）", "１５（３）", "１６（４）", "１６（５）", "１７（６）", "１７－２（７）", "１７－２（７）")
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    myPath = PathCombine(ThisWorkbook.Path, "建設業")
    myPath = PathCombine(myPath, ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value)
    
    
    Application.DisplayAlerts = False
    Workbooks.Open PathCombine(myPath, "財務諸表H.xls"), Notify:=False
    Application.DisplayAlerts = True
    
    For i = 0 To 7
        Sheets(AA(i)).Select
        Cells(1, 180).Value = "[DATA.xls]DATA!"
    Next

    Call kSyori
    
    Sheets(fNam).Select

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Sub zaimuKo(fNam As String)
    Dim AA As Variant
    Dim i As Integer
    Dim n As Integer
    Dim file_name As Object
    Dim myPath As String
    
    AA = Array("１８（１）", "１８（２）", "１９（３）")
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    
    myPath = PathCombine(ThisWorkbook.Path, "建設業")
    myPath = PathCombine(myPath, ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value)
    
    Application.DisplayAlerts = False
    Workbooks.Open PathCombine(myPath, "財務諸表k.xls"), Notify:=False
    Application.DisplayAlerts = True
    
    For i = 0 To 2
        Sheets(AA(i)).Select
        Cells(1, 180).Value = "[DATA.xls]DATA!"
    Next

    Call kSyori
    
    Sheets(fNam).Select
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub
Sub 申請書表紙へ()
    シートへ ("表紙")
End Sub
Sub 役員氏名へ()
シートへ ("役員氏名")
End Sub
Sub 見取図へ()
シートへ ("見取図")
End Sub

Sub 提出票へ()
シートへ ("提出票")
End Sub
Sub 工事経歴へ()
シートへ ("工事経歴")
End Sub
Sub zaimuMENUへ(sName As String)
    Dim msg As String
    Dim AA As Variant
    Dim i, n As Integer
    Dim file_name As Object

    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
'    msg = MsgBox("財務諸表の変更を保存しますか？", vbYesNoCancel, "建設業申請")
'    If msg = vbCancel Then
'        Application.DisplayAlerts = True
'        Exit Sub
'    ElseIf msg = vbYes Then '保存する
        Workbooks("財務諸表H.xls").Save
'    End If
    Workbooks("財務諸表H.xls").Close False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    ThisWorkbook.Activate
    Worksheets("MENU").Select

End Sub

Sub kojinMENUへ(sName As String)
    Dim msg As String
    Dim AA As Variant
    Dim i, n As Integer
    Dim file_name As Object
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
'    msg = MsgBox("財務諸表の変更を保存しますか？", vbYesNoCancel, "建設業申請")
'
'    If msg = vbCancel Then
'        Application.DisplayAlerts = True
'        Exit Sub
'    ElseIf msg = vbYes Then '保存する
        Workbooks("財務諸表K.xls").Save
'    End If
    On Error Resume Next
    Workbooks("財務諸表K.xls").Close
    On Error GoTo 0
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    ThisWorkbook.Activate
    Worksheets("MENU").Select

End Sub

Sub MENUへ(sName As String)
    Dim msg As String
    
    Application.DisplayAlerts = False
    If sName <> "DATA.xls" Then
         
'        msg = MsgBox(Left(sName, Len(sName) - 4) & "の変更を保存しますか？", vbYesNoCancel, "建設業申請")
'
'        If msg = vbCancel Then
'            Application.DisplayAlerts = True
'            Exit Sub
'        ElseIf msg = vbYes Then '保存する
            Workbooks(sName).Save
'        End If
        Workbooks(sName).Close
    
    End If
 
    Application.DisplayAlerts = True
    ThisWorkbook.Activate
    Worksheets("MENU").Select

End Sub
Sub 建設業団体へ()
シートへ ("建設業団体")
End Sub
Sub 金融機関へ()
シートへ ("金融機関")
End Sub
Sub 使用人一覧表へ()
シートへ ("使用人一覧表")
End Sub
Sub 別紙一へ()
シートへ ("役員の一覧表")
End Sub
Sub 別紙二1へ()
シートへ ("営業所一覧表新規")
End Sub
Sub 別紙二2へ()
シートへ ("営業所一覧表更新")
End Sub
Sub 専任技術者更新へ()
シートへ ("専任技術者更新")
End Sub
Sub DATAへ()
シートへ ("DATA")
End Sub
Sub 誓約書へ()
シートへ ("誓約書")
End Sub
Sub 株主調書へ()
シートへ ("株主調書")
End Sub
Sub 営業の沿革へ()
シートへ ("営業の沿革")
End Sub
Sub 使用人数へ()
シートへ ("使用人数")
End Sub
Sub 指導監督へ()
シートへ ("指導監督")
End Sub
Sub 実務経験へ()
シートへ ("実務経験")
End Sub
Sub 略歴書へ()
シートへ ("略歴書")
End Sub
Sub 使用人略歴書へ()
シートへ ("使用人略歴書")
End Sub
Sub 保険加入状況へ()
シートへ ("保険加入状況")
End Sub
Sub 許可申請書へ()
シートへ ("許可申請")
End Sub

Sub 管理責任者へ()
シートへ ("管理責任者")
End Sub
Sub 変更届へ()
シートへ ("変更届")
End Sub
Sub 専任技術者新規へ()
シートへ ("専任技術者新規")
End Sub
Sub 国家資格者へ()
シートへ ("国家資格者")
End Sub
Sub 廃業届へ()
シートへ ("廃業届")
End Sub
Sub 変更届2面へ()
シートへ ("変更届2面")
End Sub
' #20727 20130124 kon
Sub 表紙Bへ()
シートへ ("表紙Ｂ")
End Sub

Sub シート限定()
Dim s As Worksheet
  For Each s In Worksheets
    With s
      .Unprotect

    End With
  Next
Worksheets("MENU").Select
End Sub
Sub HYOUZI()
    On Error Resume Next
    ActiveSheet.Shapes("取消1").Visible = True
    ActiveSheet.Shapes("取消2").Visible = True
    ActiveSheet.Shapes("取消3").Visible = True
    ActiveSheet.Shapes("取消4").Visible = True
    ActiveSheet.Shapes("取消5").Visible = True
    ActiveSheet.Shapes("取消6").Visible = True
    ActiveSheet.Shapes("取消7").Visible = True
    ActiveSheet.Shapes("取消8").Visible = True
    ActiveSheet.Shapes("取消9").Visible = True
    ActiveSheet.Shapes("取消10").Visible = True
    ActiveSheet.Shapes("取消11").Visible = True
    ActiveSheet.Shapes("特").Visible = True
    ActiveSheet.Shapes("般").Visible = True
    ActiveSheet.Shapes("知事").Visible = True
    ActiveSheet.Shapes("大臣").Visible = True
    ActiveSheet.Shapes("局長").Visible = True
    ActiveSheet.Shapes("非局長").Visible = True
End Sub
Sub sマスター()
    Application.ScreenUpdating = False
    With ActiveWindow
        .ScrollRow = 9
        .ScrollColumn = 1
    End With
    Application.ScreenUpdating = True
End Sub
Sub s許可申請①()
    Application.ScreenUpdating = False
    With ActiveWindow
        .ScrollRow = 97
        .ScrollColumn = 1
    End With
    Application.ScreenUpdating = True
End Sub
Sub s許可申請②()
    Application.ScreenUpdating = False
    With ActiveWindow
        .ScrollRow = 151
        .ScrollColumn = 1
    End With
    Application.ScreenUpdating = True
End Sub
Sub s事業年度()
    Application.ScreenUpdating = False
    With ActiveWindow
        .ScrollRow = 202
        .ScrollColumn = 1
    End With
    Application.ScreenUpdating = True
End Sub

Sub s予備用紙()
    Application.ScreenUpdating = False
    With ActiveWindow
        .ScrollRow = 253
        .ScrollColumn = 1
    End With
    Application.ScreenUpdating = True
End Sub
Sub 県用紙()
'20140502 kon 25136
'    frmKenyousi.Show
    frmKenyousi.Show 0

End Sub
Sub 終了()
    Dim n As Integer
    Dim wb As Workbook
'    Dim strBuff As String
'20130213 KON ごちゃごちゃしていたので修正
'    If MsgBox("終了しますか？", 4 + 32, "終了") <> 6 Then Exit Sub
'    Application.ScreenUpdating = False
'    Application.DisplayAlerts = False
'
'    For Each wb In Workbooks
''            If Right(strBuff, 1) = "\" Then
''                strBuff = wb.Path
''            Else
''                strBuff = wb.Path & "\"
''            End If
''        If Dir(strBuff) = ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value Then
'            Cells(1, 7).Value = wb.Name & " 終了準備中・・・・"
''            If wb.Name = Dir(ThisWorkbook.Path & "\建設業申請\" & ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value & "\" & wb.Name) Then
'            If wb.Path = ThisWorkbook.Path & "\建設業\" & ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value Then
'                wb.Save  '強制的に保存して
'                wb.Close '強制的に閉じる
''                ThisWorkbook.Activate
''                Cells(1, 7).MergeArea.ClearContents
''                Cells(1, 7).ClearContents
'            End If
''        End If
'    Next
''    If MsgBox("終了しますか？", 4 + 32, "終了") <> 6 Then Exit Sub
'
''    Workbooks("DATA.xls").Close
''    ThisWorkbook.Activate
''    Cells(1, 7).ClearContents
''    ThisWorkbook.Worksheets("DATA").Cells(1, 1).ClearContents '画面右上の×で閉じられないようにするための印
'    Application.Run "DaAddin.xla!閉じる"
'    Application.ScreenUpdating = True
'    Application.DisplayAlerts = True

    If MsgBox("終了しますか？", 4 + 32, "終了") <> 6 Then Exit Sub
    
    Application.DisplayAlerts = False
    
    For Each wb In Workbooks
        Cells(1, 7).Value = wb.Name & " 終了準備中・・・・"
        If wb.Path = ThisWorkbook.Path & "\建設業\" & ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value Then
            DoEvents
            Application.ScreenUpdating = False
            wb.Close True '強制的に閉じる
            Application.ScreenUpdating = True
            DoEvents
        End If
    Next
    Application.Run "DaAddin.xla!閉じる"
    Application.DisplayAlerts = True


End Sub
Sub 営業年度へ()
    営業年度F.Show
End Sub

Sub 行政書士へ()
    行政書士F.Show
End Sub
Sub 管理表読込()
    Dim file_name As Object

    Application.ScreenUpdating = False
    '開いていたらActivateする
        For Each file_name In Windows
            If file_name.Caption = "管理表.xls" Then
                Workbooks("管理表.xls").Activate
                Exit Sub
            End If
    Next
    '開いていなかったら開く
    Workbooks.Open Filename:=Workbooks("建設業申請.xls").Path & "\管理表.xls"
    シート限定
    Application.ScreenUpdating = True
End Sub


Sub シート始末書へ()
Sheets("始末書").Select
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
End Sub
Sub シート届出書へ()
Sheets("届出書").Select
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
End Sub
Sub シート廃業届へ()
Sheets("廃業届").Select
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
End Sub
Sub todokeF()
届出書F.Show
End Sub
Sub Fhaigyo()

廃業届F.Show
End Sub
Sub 読込()
With Workbooks("DATA.xls").Worksheets("DATA")
Cells(43, 24).Value = .Cells(37, 2).Value
Cells(43, 28).Value = .Cells(38, 2).Value
Cells(43, 32).Value = .Cells(39, 2).Value

End With
MsgBox "OK", 64, AAA
End Sub

Sub kojin()
    frmKojin.Show
End Sub

Sub Kanu()
    Dim da As String
    da = ThisWorkbook.Worksheets("DATA").Cells(1, 1).Value
        
    With Workbooks(da).Worksheets("会社情報")
'YB32015 清水 平成28年6月版への対応でセル番地修正　ここから
'        Cells(11, 2).Value = .Cells(8, 2).Value '営業所の名称
'        '保険加入有無は、届出を行っている場合は1未加入は2適用が除外される場合は3を入力するためそれぞれの番号がある場合のみ1を入力
'        If .Cells(16, 2).Value <> "" Then
'            Cells(11, 5).Value = 1 '保険加入の有無　健保
'            Cells(11, 6).Value = 1 '保険加入の有無　年金
'        End If
'        If .Cells(36, 2).Value <> "" Then
'            Cells(11, 7).Value = 1 '保険加入の有無　雇用保険
'        End If
'        Cells(11, 9).Value = IIf(.Cells(16, 2).Value <> "", .Cells(16, 2).Value & "-" & .Cells(17, 2).Value & " " & .Cells(18, 2).Value, "") '整理記号　健保
'        Cells(12, 9).Value = IIf(.Cells(16, 2).Value <> "", .Cells(16, 2).Value & "-" & .Cells(17, 2).Value & " " & .Cells(18, 2).Value, "")   '整理記号　年金
'        '雇用保険の事業所整理記号等欄は労働保険番号を表示するそうです。労働保険番号のうち２元の雇用保険番号はわからないので空欄とします。
'        Cells(13, 9).Value = IIf(.Cells(36, 2).Value <> "", .Cells(36, 2).Value, "") '整理記号　雇用保険
        
        Cells(21, 2).Value = .Cells(8, 2).Value '営業所の名称
        '保険加入有無は、届出を行っている場合は1未加入は2適用が除外される場合は3を入力するためそれぞれの番号がある場合のみ1を入力
        If .Cells(16, 2).Value <> "" Then '社会保険記号1
            Cells(21, 12).Value = 1 '保険加入の有無　健保
            Cells(21, 17).Value = 1 '保険加入の有無　年金
        End If
        If .Cells(36, 2).Value <> "" Then '雇用保険番号
            Cells(21, 22).Value = 1 '保険加入の有無　雇用保険
        End If
        Cells(21, 32).Value = IIf(.Cells(16, 2).Value <> "", .Cells(16, 2).Value & "-" & .Cells(17, 2).Value & " " & .Cells(18, 2).Value, "") '整理記号　健保
        Cells(22, 32).Value = IIf(.Cells(16, 2).Value <> "", .Cells(16, 2).Value & "-" & .Cells(17, 2).Value & " " & .Cells(18, 2).Value, "")   '整理記号　年金
'YB32015 清水 平成28年6月版への対応でセル番地修正　ここまで
    End With


End Sub
Sub KanuKuria()
    Dim i As Integer
    
    Application.ScreenUpdating = False
    
'YB32015 2016/6/3 清水 ここから
'    Range("B11:B23").Select
'    Selection.ClearContents
'    Range("E11:G23").Select
'    Selection.ClearContents
'    Range("I11:I25").Select
'    Selection.ClearContents
'
'    Range("C12,C15,C18,C21,C24,C27").Select
'    Selection.ClearContents
'
'    For i = 13 To 28 Step 3
'        Cells(i, 3).Value = 0
'    Next i

    Range("B21:F35").Select '営業所の名称
    Selection.ClearContents
    Range("L21:Z35").Select '保険加入の有無
    Selection.ClearContents
    Range("AF21:AL35").Select '事業所整理記号等
    Selection.ClearContents
    
    Range("G22,G25,G28,G31,G34").Select '従業員数
    Selection.ClearContents
    
    For i = 23 To 35 Step 3
        Cells(i, 7).Value = 0
    Next i
'YB32015 2016/6/3 清水 ここまで
    
    Range("A1").Select
    Application.ScreenUpdating = True

End Sub

Sub kSyori()
    Application.ScreenUpdating = False
    Dim s As Worksheet
    For Each s In Worksheets
        With s
            .Activate
            ActiveWindow.DisplayHeadings = False
            .EnableSelection = xlUnlockedCells
            .Protect UserInterfaceOnly:=True
        End With
    Next
    ActiveWindow.DisplayWorkbookTabs = False
End Sub
Sub フォント切替へ()
    フォント.Show
End Sub
Sub SetList(sNo As Integer, celNo As String) '工事種類 土　1・業種　土木　2・略号セット　土木一式　3
    Dim sSiki As String


    Select Case sNo
    Case 1
        sSiki = "=INDIRECT(""[建設業申請.xls]DATA!R22C10:R49C10"",0)"
    Case 2
'        sSiki = "=INDIRECT(""[建設業申請.xls]DATA!R22C11:R49C11"",0)"
'20160822 kon 33371
'        sSiki = "=INDIRECT(""[建設業申請.xls]DATA!R22C11:R50C11"",0)"
        sSiki = "=INDIRECT(""[建設業申請.xls]DATA!R22C11:R51C11"",0)"
    Case 3
'        sSiki = "=INDIRECT(""[建設業申請.xls]DATA!R22C12:R49C12"",0)"
'20160822 kon 33371
'        sSiki = "=INDIRECT(""[建設業申請.xls]DATA!R22C12:R50C12"",0)"
        sSiki = "=INDIRECT(""[建設業申請.xls]DATA!R22C12:R51C12"",0)"
    End Select
    ActiveSheet.Unprotect
    Range(celNo).Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=sSiki
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .IMEMode = xlIMEModeNoControl
        .ShowInput = True
        .ShowError = True
        .IgnoreBlank = True
    End With
    Range("A1").Select

End Sub

Sub 健康保険加入状況Fへ()
    'YB32015 清水 2016/5/31 追加
    '様式第二十号の三（第四条、第十条関係）
    健康保険加入状況.Show
End Sub

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 = "frmYousi"
Attribute VB_Base = "0{9177DE66-7BD9-414A-8454-A46D03102D03}{A169E8F3-BCB2-4A6F-AF20-DEBC7BE30C15}"
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 CommandButton2_Click()
    Dim myFso       As Object
    Dim strPathName As String
    Dim MyB As String
    Dim ファイル名 As String

    If ListBox1.ListIndex = -1 Then
        MsgBox "ファイルが選択されていません", 16, AAA
        Exit Sub
    End If

    ファイル名 = ListBox1.List(ListBox1.ListIndex, 0) & ".xls"
    
    MyB = ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value
    strPathName = ThisWorkbook.Path & "\建設業\" & MyB
'    myFso.CopyFile ThisWorkbook.Path & "\建設業\専用用紙\" & ファイル名, strPathName & "\" & Mid(ファイル名, 4, Len(ファイル名))
    Set myFso = CreateObject("Scripting.FileSystemObject")

    
    If Dir(strPathName & "\県用紙", vbDirectory) = "" Then
        MkDir (strPathName & "\県用紙")
    End If
    myFso.CopyFile ThisWorkbook.Path & "\建設業\専用用紙\" & ファイル名, strPathName & "\県用紙" & "\" & ファイル名
    Set myFso = Nothing
    MsgBox "取り込みました。", vbInformation, "建設業申請"
'    Unload Me

End Sub

Private Sub UserForm_Activate()
    Dim MyFolname As String
    Dim Filename As String
    Dim ファイル名 As String
    
    Application.ScreenUpdating = False
    ファイル名 = Dir(ThisWorkbook.Path & "\建設業\専用用紙\", vbNormal)
…

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