Malicious Office (OOXML) — malware analysis report

Attribute VB_Name = "Module11"

Sub 特定印刷()

    '提出先入力チェック
    If Sheet2.Range("B10").Value = "" Then
        If MsgBox("提出先未入力です。印刷を実行しますか？", vbOKCancel) = vbCancel Then
            Exit Sub
        End If
    End If
        
    '印刷フッターの設定
    Dim strFt, StrFt2 As String
    'V5.0.2 ACEL 2018.05 CHG
    'strFt = "特定事業者番号：" & Sheet2.Range("T31").Value & Sheet2.Range("Y31").Value & Sheet2.Range("AD31").Value & _
            'Sheet2.Range("AI31").Value & Sheet2.Range("AN31").Value & Sheet2.Range("AS31").Value & Sheet2.Range("AX31").Value
    strFt = "特定事業者番号：" & Sheet2.Range("T31").Value & Sheet2.Range("Y31").Value & Sheet2.Range("AD31").Value & _
            Sheet2.Range("AI31").Value & Sheet2.Range("AN31").Value & Sheet2.Range("AS31").Value & Sheet2.Range("AX31").Value & vbLf & _
            "Ver" & Sheet2.Range("O1").Value
    
    Sheet2.PageSetup.LeftFooter = strFt
    Sheet3.PageSetup.LeftFooter = strFt
    Sheet4.PageSetup.LeftFooter = strFt
    
    'V5.0 ACEL
    If Application.Version = "14.0" Then
       Sheets(Array(4, 5)).Select
       ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
       Sheets(Array(6)).Select
       ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
    Else
       Sheets(Array(4, 5, 6)).Select
       ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
    End If
    Sheet5.Activate
    
End Sub


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_Open()

    Application.MoveAfterReturn = True
    Application.MoveAfterReturnDirection = xlToRight
    
    'V4.0 ACEL
    ActiveSheet.Unprotect Password:="tool"
    Sheet5.Protect UserInterfaceOnly:=True, Password:="tool"
    Sheet2.Protect UserInterfaceOnly:=True, Password:="tool"
    Sheet3.Protect UserInterfaceOnly:=True, Password:="tool"
    Sheet4.Protect UserInterfaceOnly:=True, Password:="tool"
    Sheet8.Protect UserInterfaceOnly:=True, Password:="tool"
    Sheet9.Protect UserInterfaceOnly:=True, Password:="tool"
    
  '  ActiveSheet.Protect Password:="tool"


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
Private Sub Worksheet_Change(ByVal Target As Range)

'提出先
    If (Target.row = 10) And (Target.column = 2) Then
        If Len(Cells(10, 2)) > 100 Then
          If MsgBox("提出先は100文字以内で入力して下さい。", vbOKOnly) = vbOK Then
            Cells(10, 2).Value = ""
            Cells(10, 2).Select
          End If
        End If
    End If

'社名・住所変更の有無
    If ((Target.row = 140 Or Target.row = 141) And (Target.column = 17)) Then
        If (Cells(140, 17).Value <> "") Or (Cells(141, 17).Value <> "") Then
            Shapes("Oval_有").Visible = msoTrue
            Shapes("Oval_無").Visible = msoFalse
        Else
            Shapes("Oval_有").Visible = msoFalse
            Shapes("Oval_無").Visible = msoTrue
        End If
    End If
    
'V5.0 ACEL
'商標又は商号等の保護・解除
    If ((Target.row = 31) And (Target.column = 50)) Then
        Dim cell As Range
        Set cell = Sheet4.Cells(1969, 20)
        If (Cells(31, 50).Value = "2") Then
            cell.MergeArea.Locked = False
        Else
            cell.MergeArea.Value = ""
            cell.MergeArea.Locked = True
        End If
    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 = "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_Control = "CheckBox25, 25077, 5, MSForms, CheckBox"
Attribute VB_Control = "CheckBox24, 25076, 6, MSForms, CheckBox"
Attribute VB_Control = "CheckBox23, 25075, 7, MSForms, CheckBox"
Attribute VB_Control = "TgBtt3, 24306, 8, MSForms, ToggleButton"
Attribute VB_Control = "TgBtt2, 23562, 9, MSForms, ToggleButton"
Attribute VB_Control = "TgBtt1, 23561, 10, MSForms, ToggleButton"
Attribute VB_Control = "CheckBox1, 2467, 11, MSForms, CheckBox"
Attribute VB_Control = "CheckBox2, 2466, 12, MSForms, CheckBox"
Attribute VB_Control = "CheckBox3, 2465, 13, MSForms, CheckBox"
Attribute VB_Control = "CheckBox4, 2463, 14, MSForms, CheckBox"
Attribute VB_Control = "CheckBox5, 2461, 15, MSForms, CheckBox"
Attribute VB_Control = "CheckBox6, 2460, 16, MSForms, CheckBox"
Attribute VB_Control = "CheckBox7, 2459, 17, MSForms, CheckBox"
Attribute VB_Control = "CheckBox8, 2458, 18, MSForms, CheckBox"
Attribute VB_Control = "CheckBox9, 2456, 19, MSForms, CheckBox"
Attribute VB_Control = "CheckBox10, 2455, 20, MSForms, CheckBox"
Attribute VB_Control = "CheckBox11, 2453, 21, MSForms, CheckBox"
Attribute VB_Control = "CheckBox12, 2452, 22, MSForms, CheckBox"
Attribute VB_Control = "CheckBox13, 2451, 23, MSForms, CheckBox"
Attribute VB_Control = "CheckBox14, 2449, 24, MSForms, CheckBox"
Attribute VB_Control = "CheckBox15, 2448, 25, MSForms, CheckBox"
Attribute VB_Control = "CheckBox16, 2447, 26, MSForms, CheckBox"
Attribute VB_Control = "CheckBox17, 2446, 27, MSForms, CheckBox"
Attribute VB_Control = "CheckBox18, 2445, 28, MSForms, CheckBox"
Attribute VB_Control = "CheckBox19, 2444, 29, MSForms, CheckBox"
Attribute VB_Control = "CheckBox20, 2442, 30, MSForms, CheckBox"
Attribute VB_Control = "CheckBox21, 2428, 31, MSForms, CheckBox"
Attribute VB_Control = "CheckBox22, 2427, 32, MSForms, CheckBox"
Attribute VB_Control = "TgBtt4, 24436, 33, MSForms, ToggleButton"
Option Explicit

Private Sub CheckBox7_Click()

Application.ScreenUpdating = False
Application.EnableEvents = False

If Cells(608, 63).Value = True Then
    Cells(606, 63).Value = False
    Cells(607, 63).Value = False
    Cells(611, 63).Value = False
    Cells(612, 63).Value = False
    Cells(616, 63).Value = False
    Cells(617, 63).Value = False
    Cells(613, 63).Value = True
    Cells(618, 63).Value = True
Else
    Cells(613, 63).Value = False
    Cells(618, 63).Value = False
End If

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

'V4.0 ACEL
Private Sub TgBtt1_Click()

    Dim rngStart As Range, rngEnd As Range
    Dim BX As Single, BY As Single, EX As Single, EY As Single

    If TgBtt1.Value = True Then

        ActiveSheet.Unprotect Password:="tool"

        'Shapeを配置するための基準となるセル
        Set rngStart = Range("B167")
        Set rngEnd = Range("BG162")
        
        'セルのLeft、Top、Widthプロパティを利用して位置決め
        BX = rngStart.Left
        BY = rngStart.Top
        EX = rngEnd.Left + rngEnd.Width
        EY = rngEnd.Top
        
        
        With ActiveSheet.Shapes.AddLine(BX, BY, EX, EY)
         '   .ForeColor.RGB = vbBlack
         '   .Weight = 1.5
         '  .DashStyle = msoLineSolid
           .Name = "UE"
           .Locked = True
        End With
        
        Range("B162:BG166").Select
        Selection.ClearContents

        Range("B162").Select
        ActiveSheet.Protect Password:="tool"
    
    ElseIf TgBtt1.Value = False Then

        ActiveSheet.Unprotect Password:="tool"

        ActiveSheet.Shapes("UE").Delete
        
        ActiveSheet.Protect Password:="tool"

    End If

End Sub

Private Sub TgBtt2_Click()

    Dim rngStart As Range, rngEnd As Range
    Dim BX As Single, BY As Single, EX As Single, EY As Single

    If TgBtt2.Value = True Then
    
        ActiveSheet.Unprotect Password:="tool"
    
        'Shapeを配置するための基準となるセル
        Set rngStart = Range("C185")
        Set rngEnd = Range("BF175")
        
        'セルのLeft、Top、Widthプロパティを利用して位置決め
        BX = rngStart.Left
        BY = rngStart.Top
        EX = rngEnd.Left + rngEnd.Width
        EY = rngEnd.Top
        
        
        With ActiveSheet.Shapes.AddLine(BX, BY, EX, EY)
         '   .ForeColor.RGB = vbBlack
         '   .Weight = 1.5
         '  .DashStyle = msoLineSolid
           .Name = "SITA"
           .Locked = True
        End With
        
        
        Range("C175:BF184").Select
        Selection.ClearContents
        
        Range("B175").Select
        
        ActiveSheet.Protect Password:="tool"
    
    ElseIf TgBtt2.Value = False Then
    
        ActiveSheet.Unprotect Password:="tool"
    
        ActiveSheet.Shapes("SITA").Delete
        
        ActiveSheet.Protect Password:="tool"
    
    End If

End Sub


Private Sub TgBtt3_Click()

    Dim rngStart As Range, rngEnd As Range
    Dim BX As Single, BY As Single, EX As Single, EY As Single

    If TgBtt3.Value = True Then
    
        ActiveSheet.Unprotect Password:="tool"
    
        'Shapeを配置するための基準となるセル
        Set rngStart = Range("C571")
        Set rngEnd = Range("BF561")
        
        'セルのLeft、Top、Widthプロパティを利用して位置決め
        BX = rngStart.Left
        BY = rngStart.Top
        EX = rngEnd.Left + rngEnd.Width
        EY = rngEnd.Top
        
        With ActiveSheet.Shapes.AddLine(BX, BY, EX, EY)
         '   .ForeColor.RGB = vbBlack
         '   .Weight = 1.5
         '  .DashStyle = msoLineSolid
           .Name = "TUIKA"
           .Locked = True
        End With
        
        Range("C561:BF571").Select
        Selection.ClearContents
        
        Range("B561").Select
        
        ActiveSheet.Protect Password:="tool"
        
        'ActiveSheet.Shapes("TgBtt2").Select
    
    ElseIf TgBtt3.Value = False Then
    
        ActiveSheet.Unprotect Password:="tool"
    
        ActiveSheet.Shapes("TUIKA").Delete
        
        ActiveSheet.Protect Password:="tool"
    
    End If

End Sub


Private Sub TgBtt4_Click()

    Dim rngStart As Range, rngEnd As Range
    Dim BX As Single, BY As Single, EX As Single, EY As Single

    If TgBtt4.Value = True Then
    
        ActiveSheet.Unprotect Password:="tool"
    
        'Shapeを配置するための基準となるセル
        Set rngStart = Range("B215")
        Set rngEnd = Range("BG207")
        
        'セルのLeft、Top、Widthプロパティを利用して位置決め
        BX = rngStart.Left
        BY = rngStart.Top
        EX = rngEnd.Left + rngEnd.Width
        EY = rngEnd.Top
        
        With ActiveSheet.Shapes.AddLine(BX, BY, EX, EY)
           .Name = "TUIKA2"
           .Locked = True
        End With
        
        Range("O209:BG214").Select
        Selection.ClearContents
        
                
        '2018.03 ACEL
        '設備欄
        Set rngStart = Range("B234")
        Set rngEnd = Range("BG218")
        
        'セルのLeft、Top、Widthプロパティを利用して位置決め
        BX = rngStart.Left
        BY = rngStart.Top
        EX = rngEnd.Left + rngEnd.Width
        EY = rngEnd.Top
        
        With ActiveSheet.Shapes.AddLine(BX, BY, EX, EY)
           .Name = "設備1"
           .Locked = True
        End With
        
        Range("S218:BG233").Select
        Selection.ClearContents
        
        
        Range("O209").Select
        
        ActiveSheet.Protect Password:="tool"
    
    ElseIf TgBtt4.Value = False Then
    
        ActiveSheet.Unprotect Password:="tool"
    
        ActiveSheet.Shapes("TUIKA2").Delete
        ActiveSheet.Shapes("設備1").Delete
        
        ActiveSheet.Protect Password:="tool"
    
    End If


End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Dim cr As Integer
    Dim cc As Integer

    cr = CInt(Target.row)
    cc = CInt(Target.column)
    
    '第５表（イ）変更時
    If ((Target.row >= 30 And Target.row <= 59) And (Target.column = 3)) Then
        Call LenChk(30, 59, cr, cc)
    '第５表（ロ）変更時
    ElseIf ((Target.row >= 61 And Target.row <= 90) And (Target.column = 3)) Then
        Call LenChk(61, 90, cr, cc)
    '第５表（ハ）変更時
    ElseIf ((Target.row >= 97 And Target.row <= 126) And (Target.column = 3)) Then
        Call LenChk(97, 126, cr, cc)
    '第５表（ニ）変更時
    ElseIf ((Target.row >= 128 And Target.row <= 157) And (Target.column = 3)) Then
        Call LenChk(128, 157, cr, cc)
    '第６表　ベンチマーク事業選択時
    ElseIf ((Target.row >= 162 And Target.row <= 171) And (Target.column = 2 Or Target.column = 5)) Then
        Call Benchmark_chg(cr, cc)
    '第７表  １変更時
    ElseIf ((Target.row >= 175 And Target.row <= 204) And (Target.column = 3)) Then
        Call LenChk(175, 204, cr, cc)
    ' V4.0 ACEL
    '第７表  ３変更時
    ElseIf ((Target.row >= 561 And Target.row <= 590) And (Target.column = 3)) Then
        Call LenChk(561, 590, cr, cc)
    '第９表　１変更時
    ElseIf ((Target.row >= 649 And Target.row <= 678) And (Target.column = 3)) Then
        Call LenChk(649, 678, cr, cc)
    '第９表　２変更時
    ElseIf ((Target.row >= 682 And Target.row <= 711) And (Target.column = 3)) Then
        Call LenChk(682, 711, cr, cc)
    'V4.0 ACEL
    '第１０表 指定区分の変更続きが必要変更時
    ElseIf ((Target.row >= 1015 And Target.row <= 1851) And (Target.column = 2)) Then
        Call ShiteiKubun_chg(cr, cc)
    '第１２表　５変更時
    ElseIf ((Target.row >= 2624 And Target.row <= 2653) And (Target.column = 2)) Then
        Call LenChk(2624, 2653, cr, cc)
    End If

    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub
'V4.0 ACEL
Private Sub ShiteiKubun_chg(row As Integer, column As Integer)
    If Cells(row, column).Value = "（ 指定区分の変更手続きが必要 ■ ）" Then
        Cells(row + 1, 63).Value = "TRUE"
    Else
        Cells(row + 1, 63).Value = "FALSE"
    End If
End Sub

Private Sub Benchmark_chg(cr As Integer, cc As Integer)

If cc = 2 Then
  Select Case Cells(cr, cc).Value
    
    Case "1A"
        Cells(cr, cc + 3).Value = "高炉による製鉄業"
    
    Case "1B"
        Cells(cr, cc + 3).Value = "電炉による普通鋼製造業"
    
    Case "1C"
        Cells(cr, cc + 3).Value = "電炉による特殊鋼製造業"
  
    Case "2"
        Cells(cr, cc + 3).Value = "電力供給業"
    
    Case "3"
        Cells(cr, cc + 3).Value = "セメント製造業"
    
    Case "4A"
        Cells(cr, cc + 3).Value = "洋紙製造業"
    
    Case "4B"
        Cells(cr, cc + 3).Value = "板紙製造業"

    Case "5"
        Cells(cr, cc + 3).Value = "石油精製業"
    
    Case "6A"
        Cells(cr, cc + 3).Value = "石油化学系基礎製品製造業"
    
    Case "6B"
        Cells(cr, cc + 3).Value = "ソーダ工業"
    'V4.0 ACEL
    Case "7"
        Cells(cr, cc + 3).Value = "コンビニエンスストア業"
    'V5.0 ACEL
    Case "8"
        Cells(cr, cc + 3).Value = "ホテル業"
    'V5.0 ACEL
    Case "9"
        Cells(cr, cc + 3).Value = "百貨店業"

    Case Else
        Cells(cr, cc + 3).Value = ""

  End Select

ElseIf cc = 5 Then

  Select Case Cells(cr, cc).Value
    
    Case "高炉による製鉄業"
        Cells(cr, cc - 3).Value = "1A"
    
    Case "電炉による普通鋼製造業"
        Cells(cr, cc - 3).Value = "1B"
    
    Case "電炉による特殊鋼製造業"
        Cells(cr, cc - 3).Value = "1C"
  
    Case "電力供給業"
        Cells(cr, cc - 3).Value = "2"
    
    Case "セメント製造業"
        Cells(cr, cc - 3).Value = "3"
    
    Case "洋紙製造業"
        Cells(cr, cc - 3).Value = "4A"
    
    Case "板紙製造業"
        Cells(cr, cc - 3).Value = "4B"

    Case "石油精製業"
        Cells(cr, cc - 3).Value = "5"
    
    Case "石油化学系基礎製品製造業"
        Cells(cr, cc - 3).Value = "6A"
    
    Case "ソーダ工業"
        Cells(cr, cc - 3).Value = "6B"
    'V4.0 ACEL
    Case "コンビニエンスストア業"
        Cells(cr, cc - 3).Value = "7"
    'V5.0 ACEL
    Case "ホテル業"
        Cells(cr, cc - 3).Value = "8"
    'V5.0 ACEL
    Case "百貨店業"
        Cells(cr, cc - 3).Value = "9"

    Case Else
        Cells(cr, cc - 3).Value = ""

  End Select


End If


End Sub
Private Sub LenChk(sr As Integer, er As Integer, cr As Integer, cc As Integer)

    Dim dcnt As Integer
    Dim ccnt As Integer
    Dim lcnt As Integer
    Dim ar As Integer
    Dim strb As String

    lcnt = 0
    ccnt = 0

    '表示されている行の文字数をカウント
    For ar = sr To er
      If Rows(ar).Hidden = False Then
        lcnt = lcnt + 1
        ccnt = ccnt + Len(Rows(ar).Columns(cc))
      Else
        Exit For
      End If
    Next
    
    '最終行以外に付加する"\n"の分を加算
    ccnt = ccnt + ((lcnt - 1) * 2)
    
'    '1,600文字を超えていたらメッセージ表示
    If ccnt > 1600 Then
        If MsgBox("1600文字以内で入力して下さい。", vbOKOnly) = vbOK Then
            dcnt = ccnt - 1600
            If dcnt > Len(Rows(cr).Columns(cc)) Then
                Rows(cr).Columns(cc).Value = ""
            Else
                strb = Left(Rows(cr).Columns(cc).Value, Len(Rows(cr).Columns(cc)) - dcnt)
                Rows(cr).Columns(cc).Value = strb
            End If
            Rows(cr).Columns(cc).Select
        End If
    End If

End Sub

Attribute VB_Name = "Sheet5"
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_Control = "CheckBox1, 9, 0, MSForms, CheckBox"

Attribute VB_Name = "Sheet1"
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 = "Sheet6"
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 = "Module1"
Sub 代理報告ボタン_Click()

'
'代理報告者　表示／非表示切替
'

  Application.ScreenUpdating = False
  
  If Rows(23).Hidden = True Then
      Rows(23).Hidden = False
      Rows(24).Hidden = False
      Range("AK23").Value = Range("BL23").Value
      Range("AK24").Value = Range("BL24").Value
      Range("AK23").Select
      ActiveSheet.Shapes("ボタン 代理").Select
      Selection.Characters.Text = "本人提出"
      Range("AK23").Select
      ActiveSheet.Shapes("角丸四角形吹き出し 2").Visible = True
      
  Else
      Range("BL23").Value = Range("AK23").Value
      Range("BL24").Value = Range("AK24").Value
      Range("AK23").Value = ""
      Range("AK24").Value = ""
      Rows(23).Hidden = True
      Rows(24).Hidden = True
      ActiveSheet.Shapes("ボタン 代理").Select
      Selection.Characters.Text = "代理提出"
      Range("AK21").Select
      ActiveSheet.Shapes("角丸四角形吹き出し 2").Visible = False
  End If

  Application.ScreenUpdating = True

End Sub
Sub 未選任ボタン_Click()

'
'エネルギー管理者　選任／未選任切替
'

  Dim s1
  Dim s1name, s1_addr, s1_top
  Dim s2name
  Dim rr
  Dim obj As Object
  Dim nm   As String
  Dim nmr7 As String
  Dim bcnt
    
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  
    '「未選任」ボタンの位置情報を取得
    Set obj = ActiveSheet.DrawingObjects(Application.Caller)
    s1name = obj.Name
    
    Set s1 = ActiveSheet.Shapes(s1name)
    s1_addr = s1.TopLeftCell.Address
    
    Range(s1_addr).Select
    
    With Range(s1_addr).MergeArea
        rr = .Item(1).row
    End With
 
  bcnt = (rr + 9 - 50) / 9
 
  If Range("T" & rr + 1).Value = "選任中" Then
      Range("T" & rr + 1).Value = Range("BL" & rr + 1).Value
      nm = Range("W" & rr - 1).Value
      nmr7 = Right(nm, 7)
      If nmr7 = "（作成実務者）" Then
          Range("W" & rr - 1).Value = Left(nm, Len(nm) - 7)
      End If
      ActiveSheet.Shapes("ボタン 選任" & bcnt).Select
      Selection.Characters.Text = "未選任"
      Range("T" & rr + 1).Select
  Else
      Range("BL" & rr + 1).Value = Range("T" & rr + 1).Value
      Range("T" & rr + 1).Value = "選任中"
      nm = Range("W" & rr - 1).Value
      nmr7 = Right(nm, 7)
      If nmr7 = "（作成実務者）" Then
      Else
          Range("W" & rr - 1).Value = nm & "（作成実務者）"
      End If
      ActiveSheet.Shapes("ボタン 選任" & bcnt).Select
      Selection.Characters.Text = "選任済"
      Range("Y" & rr + 2).Select
  End If
  
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  
End Sub
Sub 同じボタン_Click()
    Dim s1
    Dim s1name, s1_addr, s1_top
    Dim s2name
    Dim rr
    Dim obj As Object
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    '「同じ」ボタンの位置情報を取得
    Set obj = ActiveSheet.DrawingObjects(Application.Caller)
    s1name = obj.Name
    
    Set s1 = ActiveSheet.Shapes(s1name)
    s1_addr = s1.TopLeftCell.Address
    
    Range(s1_addr).Select
    
    With Range(s1_addr).MergeArea
        rr = .Item(1).row
    End With
 
    If Range("V34").Value = "" And Range("T35").Value = "" Then
      If MsgBox("主たる事務所の所在地が入力されていません。", vbOKOnly) = vbOK Then
        Exit Sub
      End If
    End If
      
    Range("Y" & rr).Value = Range("V34").Value
    Range("T" & rr + 1).Value = Range("T35").Value
  
    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub


Attribute VB_Name = "Module2"
Sub ボタン表3_Click()

    Dim s1
    Dim s1name, s1_addr, s1_top
    Dim s2name
    Dim lch
    Dim cno
    Dim rr
    Dim ar
    Dim obj As Object
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    '「＋」ボタンの位置情報を取得
    Set obj = ActiveSheet.DrawingObjects(Application.Caller)
    s1name = obj.Name
    
    Set s1 = ActiveSheet.Shapes(s1name)
    s1_addr = s1.TopLeftCell.Address
    
    Range(s1_addr).Select
    
    With Range(s1_addr).MergeArea
        rr = .Item(1).row
    End With
    
    '次の3件を表示
    For ar = (rr + 1) To (rr + 9)
        ActiveSheet.Rows(ar).Hidden = False
    Next
    
    '特定３表 １のとき、特定３表　２も連動させる
    If Left(s1name, 7) = "ボタン表3_1" Then
    For ar = (rr + 382) To (rr + 390)
        ActiveSheet.Rows(ar).Hidden = False
    Next
    End If
    
    'ボタン表示制御
    ActiveSheet.Shapes(s1name).Visible = False
    
    lch = Left(s1name, Len(s1name) - 3)
    cno = Right(s1name, 3)
    
    If cno > 101 Then
        s2name = lch & cno - 1 & "D"
        ActiveSheet.Shapes(s2name).Visible = False
    End If
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub
Sub ボタン表579_Click()

    Dim s1
    Dim s1name, s1_addr, s1_top
    Dim s2name
    Dim lch
    Dim cno
    Dim rr
    Dim ar
    Dim obj As Object
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    '「＋」ボタンの位置情報を取得
    Set obj = ActiveSheet.DrawingObjects(Application.Caller)
    s1name = obj.Name
    
    Set s1 = ActiveSheet.Shapes(s1name)
    s1_addr = s1.TopLeftCell.Address
    
    Range(s1_addr).Select
    
    With Range(s1_addr).MergeArea
        rr = .Item(1).row
    End With
    
    '次の10行を表示
    For ar = (rr + 1) To (rr + 10)
        ActiveSheet.Rows(ar).Hidden = False
    Next
    
    'ボタン表示制御
    ActiveSheet.Shapes(s1name).Visible = False
    
    lch = Left(s1name, Len(s1name) - 1)
    cno = Right(s1name, 1)
    
    If cno > 1 Then
        s2name = lch & cno - 1 & "D"
        ActiveSheet.Shapes(s2name).Visible = False
    End If
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub
Sub ボタン表11_Click()

    Dim s1
    Dim s1name, s1_addr, s1_top
    Dim rr
    Dim ar
    Dim obj As Object
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    '「＋」ボタンの位置情報を取得
    Set obj = ActiveSheet.DrawingObjects(Application.Caller)
    s1name = obj.Name
    
    Set s1 = ActiveSheet.Shapes(s1name)
    s1_addr = s1.TopLeftCell.Address
    
    Range(s1_addr).Select
    
    With Range(s1_addr).MergeArea
        rr = .Item(1).row
    End With
    
    '次の5件を表示
    For ar = (rr + 1) To (rr + 15)
        ActiveSheet.Rows(ar).Hidden = False
    Next
    
    'ボタン表示制御
    ActiveSheet.Shapes(s1name).Visible = False
    
    Select Case (s1name)
    
    Case "ボタン表11_2"
        ActiveSheet.Shapes("ボタン表11_1D").Visible = False
       
    Case "ボタン表11_3"
        ActiveSheet.Shapes("ボタン表11_2D").Visible = False
       
    Case "ボタン表11_4"
        ActiveSheet.Shapes("ボタン表11_3D").Visible = False
    
    End Select

    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub
Sub ボタン表12行追加_Click()

    Dim s1
    Dim s1name, s1_addr, s1_top
    Dim s2name
    Dim lch
    Dim cno
    Dim rr
    Dim ar
    Dim obj As Object
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    '「＋」ボタンの位置情報を取得
    Set obj = ActiveSheet.DrawingObjects(Application.Caller)
    s1name = obj.Name
    
    Set s1 = ActiveSheet.Shapes(s1name)
    s1_addr = s1.TopLeftCell.Address
    
    Range(s1_addr).Select
    
    With Range(s1_addr).MergeArea
        rr = .Item(1).row
    End With
    
    '次の5件を表示
    For ar = (rr + 1) To (rr + 5)
        ActiveSheet.Rows(ar).Hidden = False
    Next
    
    'ボタン表示制御
    ActiveSheet.Shapes(s1name).Visible = False
    
    lch = Left(s1name, Len(s1name) - 2)
    cno = Right(s1name, 2)
    
    If (cno > 11 And cno < 20) Or _
       (cno > 21 And cno < 30) Or _
       (cno > 31 And cno < 40) Or _
       (cno > 41 And cno < 50) Then
        s2name = lch & cno - 1 & "D"
        ActiveSheet.Shapes(s2name).Visible = False
    End If
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub
Sub ボタン表12表追加_Click()

    Dim s1
    Dim s1name, s1_addr, s1_top
    Dim rr
    Dim ar
    Dim obj As Object
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    '「＋」ボタンの位置情報を取得
    Set obj = ActiveSheet.DrawingObjects(Application.Caller)
    s1name = obj.Name
    
    Set s1 = ActiveSheet.Shapes(s1name)
    s1_addr = s1.TopLeftCell.Address
    
    Range(s1_addr).Select
    
    With Range(s1_addr).MergeArea
        rr = .Item(1).row
    End With
    
    '次の表を表示
    For ar = (rr + 1) To (rr + 13)
        ActiveSheet.Rows(ar).Hidden = False
    Next
    
    ActiveSheet.Rows(ar + 25).Hidden = False
    
    ActiveSheet.Shapes(s1name).Visible = False
    
    Select Case (s1name)
    
    'ボタン表示制御
    Case "ボタン表12_6_3_2"
…