ken_nogi/XVBA/マトリックス積算/xxx抽出マクロ copy.bas

Option Explicit

' 共通シート名定義
Public Const SHEET_N_SASHI As String = "Nサッシ"
Public Const SHEET_N_TATEGU As String = "N建具"
Public Const SHEET_N_SETUBI As String = "N設備"
Public Const SHEET_N_ZATSU As String = "N雑工事"

Public Const SHEET_B_SASHI As String = "Bサッシ"
Public Const SHEET_B_TATEGU As String = "B建具"
Public Const SHEET_B_SETUBI As String = "B設備"
Public Const SHEET_B_ZATSU As String = "B雑工事"

Public Const SHEET_A_SASHI As String = "Aサッシ"
Public Const SHEET_A_TATEGU As String = "A建具"
Public Const SHEET_A_SETUBI As String = "A設備"
Public Const SHEET_A_ZATSU As String = "A雑工事"

Public Const SHEET_MITSUMORI As String = "見積書表紙"
Public Const SHEET_MEISAI As String = "明細書"
Public Const SHEET_KIHON As String = "基本入力"
Public Const SHEET_SHOKEIHI As String = "諸経費"


Sub 明細の抽出()
    ' 必要項目入力チェック
    If Not 必須入力チェック結果() Then
        Exit Sub
    End If

    Application.ScreenUpdating = False

    Call 抽出シートクリア("抽出")
    Call 明細情報抽出("サッシ工事", "抽出")
    Call 明細情報抽出("建具工事", "抽出")
    Call 明細情報抽出("設備工事", "抽出")
    Call 明細情報抽出("雑工事", "抽出")

    Call 明細書シートに移動
    Call 明細書印刷範囲設定

    Application.ScreenUpdating = True
    MsgBox "抽出と金額計算が完了しました", vbInformation
End Sub

Sub 明細情報抽出(ByVal categoryName As String, ByVal destSheetName As String)
    Dim srcWs As Worksheet, destWs As Worksheet
    Dim srcTbl As ListObject
    Dim srcTblF As ListObject
    Dim destRow As Long, i As Long
    Dim colProduct As Integer, colPrice As Integer, colQty As Integer, colUnitName As Integer
    Dim colCategory As Integer
    Dim 金額 As Double, subtotal As Double
    Dim lastRow As Long
    Dim isFirst As Boolean

    '--- 対象のテーブル情報 ---
    Dim srcSheetName As String
    Dim srcTableName As String
    Dim srcTableNameF As String
    srcSheetName = Range(categoryName).Value
    srcTableName = Range(categoryName).Value
    srcTableNameF = srcTableName & "F"

    '--- 設定 ---
    Set srcWs = ThisWorkbook.Sheets(srcSheetName)
    Set destWs = ThisWorkbook.Sheets(destSheetName)
    Set srcTbl = srcWs.ListObjects(srcTableName)
    Set srcTblF = srcWs.ListObjects(srcTableNameF)

    Dim 減坪表示区分 As String
    減坪表示区分 = Range("減坪表示区分").Value

    '列番号取得（列名は実際のものに合わせてください）
    colProduct = srcTbl.ListColumns("商品名").Index
    colPrice = srcTbl.ListColumns("単価").Index
    colQty = srcTbl.ListColumns("数量").Index
    colUnitName = srcTbl.ListColumns("単位名").Index
    colCategory = srcTbl.ListColumns("カテゴリ").Index

    '--- データ書き込み開始行の決定 ---
    lastRow = destWs.Cells(destWs.Rows.Count, 1).End(xlUp).Row
    If destWs.Cells(1, 1).Value = "" Then
        ' シートが空の場合
        destRow = 1
        isFirst = True
    Else
        destRow = lastRow + 1
        isFirst = False
    End If

    '--- カテゴリ一覧取得 ---
    Dim categoryDict As Object
    Set categoryDict = CreateObject("Scripting.Dictionary")
    For i = 1 To srcTbl.ListRows.Count
        Dim catName As String
        catName = srcTbl.DataBodyRange(i, colCategory).Value
        If Not categoryDict.Exists(catName) And catName <> "" Then
            categoryDict.Add catName, True
        End If
    Next i
    For i = 1 To srcTblF.ListRows.Count
        Dim catNameF As String
        catNameF = srcTblF.DataBodyRange(i, colCategory).Value
        If Not categoryDict.Exists(catNameF) And catNameF <> "" Then
            categoryDict.Add catNameF, True
        End If
    Next i

    '--- カテゴリごとに抽出 ---
    Dim key As Variant
    For Each key In categoryDict.Keys
        Dim hasItem As Boolean
        hasItem = False

        Dim categorySubtotal As Double
        categorySubtotal = 0

        ' 通常テーブルにアイテムがあるか判定
        For i = 1 To srcTbl.ListRows.Count
            If srcTbl.DataBodyRange(i, colQty).Value > 0 And srcTbl.DataBodyRange(i, colCategory).Value = key Then
                hasItem = True
                Exit For
            End If
        Next i

        ' オプション欄テーブルにアイテムがあるか判定
        If Not hasItem Then
            For i = 1 To srcTblF.ListRows.Count
                If srcTblF.DataBodyRange(i, colQty).Value > 0 And srcTblF.DataBodyRange(i, colCategory).Value = key Then
                    hasItem = True
                    Exit For
                End If
            Next i
        End If

        If hasItem Then
            ' カテゴリ名ヘッダー出力
            destWs.Cells(destRow, 1).Value = key
            destRow = destRow + 1

            ' 通常テーブル
            For i = 1 To srcTbl.ListRows.Count
                If srcTbl.DataBodyRange(i, colQty).Value > 0 And srcTbl.DataBodyRange(i, colCategory).Value = key Then
                    destWs.Cells(destRow, 1).Value = "　" + srcTbl.DataBodyRange(i, colProduct).Value
                    destWs.Cells(destRow, 2).Value = srcTbl.DataBodyRange(i, colPrice).Value

                    ' 数量は小数点以下第3位以下を切り捨て
                    Dim qtyValue As Double
                    qtyValue = srcTbl.DataBodyRange(i, colQty).Value
                    qtyValue = Int(qtyValue * 100) / 100
                    destWs.Cells(destRow, 3).Value = qtyValue
                    destWs.Cells(destRow, 4).Value = srcTbl.DataBodyRange(i, colUnitName).Value
                    ' 金額は単価×数量で計算し、小数点以下切り捨て
                    金額 = srcTbl.DataBodyRange(i, colPrice).Value * qtyValue
                    金額 = Int(金額)
                    destWs.Cells(destRow, 5).Value = 金額
                    categorySubtotal = categorySubtotal + 金額
                    destRow = destRow + 1
                End If
            Next i

            ' オプション欄テーブル
            For i = 1 To srcTblF.ListRows.Count
                If srcTblF.DataBodyRange(i, colQty).Value > 0 And srcTblF.DataBodyRange(i, colCategory).Value = key Then
                    destWs.Cells(destRow, 1).Value = "　" + srcTblF.DataBodyRange(i, colProduct).Value
                    destWs.Cells(destRow, 2).Value = srcTblF.DataBodyRange(i, colPrice).Value

                    ' 数量は小数点以下第3位以下を切り捨て
                    Dim qtyValueF As Double
                    qtyValueF = srcTblF.DataBodyRange(i, colQty).Value
                    qtyValueF = Int(qtyValueF * 100) / 100
                    destWs.Cells(destRow, 3).Value = qtyValueF
                    destWs.Cells(destRow, 4).Value = srcTblF.DataBodyRange(i, colUnitName).Value
                    ' 金額は単価×数量で計算し、小数点以下切り捨て
                    金額 = srcTblF.DataBodyRange(i, colPrice).Value * qtyValueF
                    金額 = Int(金額)
                    destWs.Cells(destRow, 5).Value = 金額
                    categorySubtotal = categorySubtotal + 金額
                    destRow = destRow + 1
                End If
            Next i

            '--- 雑工事の場合、減坪金額を調べて追記 ---
            If categoryName = "雑工事" And 減坪表示区分 = "雑工事" Then
                ' 減坪表示区分が空欄の場合は、末尾にカテゴリ名を指定して減坪計算を表示

                'If Range("_1階減坪_金額").Value <> 0 Or Range("_23階減坪_金額").Value <> 0 Or Range("オーバーハング用減坪_金額").Value <> 0 Then
                '    destWs.Cells(destRow, 1).Value = Range("減坪カテゴリ名").Value
                '    destRow = destRow + 1
                'End If

                If Range("_1階減坪_金額").Value <> 0 Then
                    destWs.Cells(destRow, 1).Value = "　1階減坪（" & Range("選択スタイル").Value & "）"
                    destWs.Cells(destRow, 2).Value = Range("_1階減坪_単価").Value
                    destWs.Cells(destRow, 3).Value = Range("_1階減坪_数量").Value
                    destWs.Cells(destRow, 4).Value = "坪"
                    金額 = Range("_1階減坪_金額").Value
                    destWs.Cells(destRow, 5).Value = 金額
                    '減坪小計 = 減坪小計 + 金額
                    categorySubtotal = categorySubtotal + 金額
                    destRow = destRow + 1
                End If
                If Range("_23階減坪_金額").Value <> 0 Then
                    destWs.Cells(destRow, 1).Value = "　2,3階減坪（" & Range("選択スタイル").Value & "）"
                    destWs.Cells(destRow, 2).Value = Range("_23階減坪_単価").Value
                    destWs.Cells(destRow, 3).Value = Range("_23階減坪_数量").Value
                    destWs.Cells(destRow, 4).Value = "坪"
                    金額 = Range("_23階減坪_金額").Value
                    destWs.Cells(destRow, 5).Value = 金額
                    '減坪小計 = 減坪小計 + 金額
                    categorySubtotal = categorySubtotal + 金額
                    destRow = destRow + 1
                End If
                If Range("オーバーハング用減坪_金額").Value <> 0 Then
                    destWs.Cells(destRow, 1).Value = "　オーバーハング用減坪（" & Range("選択スタイル").Value & "）"
                    destWs.Cells(destRow, 2).Value = Range("オーバーハング用減坪_単価").Value
                    destWs.Cells(destRow, 3).Value = Range("オーバーハング用減坪_数量").Value
                    destWs.Cells(destRow, 4).Value = "坪"
                    金額 = Range("オーバーハング用減坪_金額").Value
                    destWs.Cells(destRow, 5).Value = 金額
                    '減坪小計 = 減坪小計 + 金額
                    categorySubtotal = categorySubtotal + 金額
                    destRow = destRow + 1
                End If

                ' 減坪小計が0以外なら小計行を挿入
                'If 減坪小計 <> 0 Then
                '    destWs.Cells(destRow, 1).Value = "　小計"
                '    destWs.Cells(destRow, 5).Value = 減坪小計
                '    destRow = destRow + 1
                'End If

            End If


            '--- 小計行 ---
            If categorySubtotal <> 0 Then
                destWs.Cells(destRow, 1).Value = "　小計"
                destWs.Cells(destRow, 5).Value = categorySubtotal
                destRow = destRow + 1
            End If
        End If
    Next key

    '--- 雑工事の場合、減坪金額を調べて追記 ---
    If categoryName = "雑工事" And 減坪表示区分 = "" Then
        ' 減坪表示区分が空欄の場合は、末尾にカテゴリ名を指定して減坪計算を表示
        Dim 減坪小計 As Double
        減坪小計 = 0

        If Range("_1階減坪_金額").Value <> 0 Or Range("_23階減坪_金額").Value <> 0 Or Range("オーバーハング用減坪_金額").Value <> 0 Then
            destWs.Cells(destRow, 1).Value = Range("減坪カテゴリ名").Value
            destRow = destRow + 1
        End If

        If Range("_1階減坪_金額").Value <> 0 Then
            destWs.Cells(destRow, 1).Value = "　1階減坪（" & Range("選択スタイル").Value & "）"
            destWs.Cells(destRow, 2).Value = Range("_1階減坪_単価").Value
            destWs.Cells(destRow, 3).Value = Range("_1階減坪_数量").Value
            destWs.Cells(destRow, 4).Value = "坪"
            金額 = Range("_1階減坪_金額").Value
            destWs.Cells(destRow, 5).Value = 金額
            減坪小計 = 減坪小計 + 金額
            destRow = destRow + 1
        End If
        If Range("_23階減坪_金額").Value <> 0 Then
            destWs.Cells(destRow, 1).Value = "　2,3階減坪（" & Range("選択スタイル").Value & "）"
            destWs.Cells(destRow, 2).Value = Range("_23階減坪_単価").Value
            destWs.Cells(destRow, 3).Value = Range("_23階減坪_数量").Value
            destWs.Cells(destRow, 4).Value = "坪"
            金額 = Range("_23階減坪_金額").Value
            destWs.Cells(destRow, 5).Value = 金額
            減坪小計 = 減坪小計 + 金額
            destRow = destRow + 1
        End If
        If Range("オーバーハング用減坪_金額").Value <> 0 Then
            destWs.Cells(destRow, 1).Value = "　オーバーハング用減坪（" & Range("選択スタイル").Value & "）"
            destWs.Cells(destRow, 2).Value = Range("オーバーハング用減坪_単価").Value
            destWs.Cells(destRow, 3).Value = Range("オーバーハング用減坪_数量").Value
            destWs.Cells(destRow, 4).Value = "坪"
            金額 = Range("オーバーハング用減坪_金額").Value
            destWs.Cells(destRow, 5).Value = 金額
            減坪小計 = 減坪小計 + 金額
            destRow = destRow + 1
        End If

        ' 減坪小計が0以外なら小計行を挿入
        If 減坪小計 <> 0 Then
            destWs.Cells(destRow, 1).Value = "　小計"
            destWs.Cells(destRow, 5).Value = 減坪小計
            destRow = destRow + 1
        End If
    End If

End Sub

Sub 抽出シートクリア(ByVal destSheetName As String)
    Dim destWs As Worksheet
    Set destWs = ThisWorkbook.Sheets(destSheetName)
    destWs.Cells.ClearContents
End Sub

Sub シートの切り替え()
    Application.ScreenUpdating = False
    '全シート非表示
    Call 全シート非表示

    '必要なシートのみ表示
    Call 指定シート表示("サッシ工事")
    Call 指定シート表示("建具工事")
    Call 指定シート表示("設備工事")
    Call 指定シート表示("雑工事")

    Application.ScreenUpdating = True
End Sub

Sub 全シート非表示()
    Dim ws As Worksheet

    ' 指定以外のシートを非表示
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> SHEET_MITSUMORI And ws.Name <> SHEET_MEISAI And ws.Name <> SHEET_KIHON And ws.Name <> SHEET_SHOKEIHI Then
            ws.Visible = xlSheetHidden
        Else
            ws.Visible = xlSheetVisible
        End If
    Next ws
End Sub

Sub 指定シート表示(ByVal shName As String)
    Dim sh As String
    sh = Range(shName).Value
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(sh)
    ws.Visible = xlSheetVisible
End Sub

Sub 基本入力シートに戻る()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(SHEET_KIHON)
    ws.Activate
    ws.Range("A1").Select
End Sub

Sub 見積書シートに移動()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(SHEET_MITSUMORI)
    ws.Activate
    ws.Range("A1").Select
End Sub

Sub 明細書シートに移動()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(SHEET_MEISAI)
    ws.Activate
    ws.Range("A1").Select
End Sub

Sub セル参照でシート移動(ByVal sheetName As String)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(sheetName)
    If ws.Visible = xlSheetHidden Or ws.Visible = xlSheetVeryHidden Then
        Call シートの切り替え
    End If
    ws.Activate
    ws.Range("E4").Select
End Sub

Sub サッシ工事テーブルへ移動()
    If Range("選択ブランド").Value = "" Then
        MsgBox "ブランドが選択されていません。", vbExclamation
     Exit Sub
    End If
    Call セル参照でシート移動(Range("サッシ工事").Value)
End Sub

Sub 内部建具工事テーブルへ移動()
    If Range("選択ブランド").Value = "" Then
        MsgBox "ブランドが選択されていません。", vbExclamation
     Exit Sub
    End If
    Call セル参照でシート移動(Range("建具工事").Value)
End Sub

Sub 設備工事テーブルへ移動()
    If Range("選択ブランド").Value = "" Then
        MsgBox "ブランドが選択されていません。", vbExclamation
     Exit Sub
    End If
    Call セル参照でシート移動(Range("設備工事").Value)
End Sub

Sub 雑工事テーブルへ移動()
    If Range("選択ブランド").Value = "" Then
        MsgBox "ブランドが選択されていません。", vbExclamation
     Exit Sub
    End If
    Call セル参照でシート移動(Range("雑工事").Value)
End Sub

Sub 諸経費テーブルへ移動()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(SHEET_SHOKEIHI)
    ws.Activate
    ws.Range("C6").Select
End Sub

Sub クリア()
    Application.ScreenUpdating = False

    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    On Error Resume Next
    Set tbl = ws.ListObjects(ws.Name)
    On Error GoTo 0
    If Not tbl Is Nothing Then
        Dim colQty As Integer
        On Error Resume Next
        colQty = tbl.ListColumns("数量").Index
        On Error GoTo 0
        If colQty > 0 Then
            ' 数量列の入力範囲を一括選択してまとめて削除
            tbl.DataBodyRange.Columns(colQty).ClearContents
         End If
    End If

    Application.ScreenUpdating = True
End Sub

Sub オプション欄クリア()
    Application.ScreenUpdating = False

    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tblF As ListObject
    On Error Resume Next
    Set tblF = ws.ListObjects(ws.Name + "F")
    Dim defaultCategoryName As String
    defaultCategoryName = Range(ws.Range("B2").Value & "Fカテゴリ名").Value

    If Not tblF Is Nothing Then
        tblF.DataBodyRange.ClearContents
    End If

    ' カテゴリ列にB2セルの値を一括セット
    Dim colCategory As Integer
    On Error Resume Next
    colCategory = tblF.ListColumns("カテゴリ").Index
    On Error GoTo 0
    If colCategory > 0 Then
        tblF.DataBodyRange.Columns(colCategory).Value = defaultCategoryName
    End If

    Application.ScreenUpdating = True
End Sub

Sub 見積書明細書PDF出力()

    ' 必要項目入力チェック
    If Not 必須入力チェック結果() Then
        Exit Sub
    End If

    If MsgBox("PDF形式で出力します。同じ名前のファイルがある場合は上書きされます。よろしいですか？", vbYesNo + vbQuestion, "確認") = vbNo Then
        Exit Sub
    End If

    ' まずは保存
    ThisWorkbook.Save

    Dim wsMitsumori As Worksheet, wsMeisai As Worksheet
    Dim pdfFileName As String
    Dim folderPath As String
    Dim koujiName As String, issueDate As String

    Set wsMitsumori = ThisWorkbook.Sheets(SHEET_MITSUMORI)
    Set wsMeisai = ThisWorkbook.Sheets(SHEET_MEISAI)

    ' 保存先フォルダ（必要に応じて変更）
    folderPath = ThisWorkbook.Path & "\"

    ' ファイル名用情報取得
    koujiName = Range("工事名").Value
    issueDate = Range("発行年月日").Value

    ' 日付を"yyyyMMddHHmmss"形式に
    Dim dt As String
    dt = Format(issueDate, "yyyymmdd")

    ' ファイル名作成（見積書番号は含めない）
    pdfFileName = folderPath & "マトリックス積算" & " " & koujiName & " 見積書" & dt & ".pdf"

    ' シートを配列で指定してPDF出力
    Sheets(Array(SHEET_MITSUMORI, SHEET_MEISAI)).Select
    On Error GoTo ExportError
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=pdfFileName, Quality:=xlQualityStandard
    On Error GoTo 0
    GoTo ExportEnd

ExportError:
    MsgBox "PDFのエクスポートに失敗しました。同じ名前のファイルが開かれていないか確認してください。" & vbCrLf & "ファイル名: " & pdfFileName, vbExclamation
    Exit Sub

ExportEnd:

    ' 元のシートに戻る
    Call 基本入力シートに戻る

    MsgBox "PDF出力が完了しました。" & vbCrLf & pdfFileName, vbInformation
End Sub

Sub 明細書印刷範囲設定()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim 合計Row As Long
    Dim printStartRow As Long, printEndRow As Long

    Set ws = ThisWorkbook.Sheets(SHEET_MEISAI)

    ' B列の最終行取得
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

    ' B列の最終行から上方向に「合計」を探す
    合計Row = 0
    Dim i As Long
    For i = lastRow To 2 Step -1
        If ws.Cells(i, "B").Value = "合計" Then
            合計Row = i
         Exit For
        End If
    Next i

    If 合計Row = 0 Then
        MsgBox "「合計」が見つかりません。", vbExclamation
     Exit Sub
    End If

    printStartRow = 2
    printEndRow = 合計Row + 1 ' 合計行の次の行まで

    ws.PageSetup.PrintArea = ws.Range("B" & printStartRow & ":F" & printEndRow).Address
    'MsgBox "印刷範囲をF" & printStartRow & "～F" & printEndRow & "に設定しました。", vbInformation

End Sub

Sub 入力内容をすべてクリア()
    If MsgBox("基本情報および部材リストの選択をすべてクリアします、よろしいですか？", vbYesNo + vbQuestion, "確認") = vbNo Then
     Exit Sub
    End If

    Application.ScreenUpdating = False
    Call 基本入力のE列クリア
    Call 複数シート数量クリア
    Call すべてのオプション欄のクリア
    Call 諸経費シートのクリア
    Call 抽出シートクリア("抽出")
    Call 指定以外のシートを非表示
    Application.ScreenUpdating = True

End Sub

Sub 複数シート数量クリア()
    Application.ScreenUpdating = False

    Dim sheetNames As Variant
    Dim i As Integer
    Dim ws As Worksheet

    ' 部材シートの数量クリア
    sheetNames = Array(SHEET_N_SASHI, SHEET_N_TATEGU, SHEET_N_SETUBI, SHEET_N_ZATSU, _
                       SHEET_B_SASHI, SHEET_B_TATEGU, SHEET_B_SETUBI, SHEET_B_ZATSU, _
                       SHEET_A_SASHI, SHEET_A_TATEGU, SHEET_A_SETUBI, SHEET_A_ZATSU)
    For i = LBound(sheetNames) To UBound(sheetNames)
        On Error Resume Next
        Set ws = ThisWorkbook.Sheets(sheetNames(i))

        If Not ws Is Nothing Then
            On Error Resume Next
            Dim tbl As ListObject
            Set tbl = ws.ListObjects(ws.Name)
            If Not tbl Is Nothing Then
                Dim colQty As Integer
                colQty = tbl.ListColumns("数量").Index
                ' 数量列の入力範囲を一括選択してまとめて削除
                tbl.DataBodyRange.Columns(colQty).ClearContents
            End If
            On Error GoTo 0
        End If

        On Error GoTo 0
    Next i

    Application.ScreenUpdating = True
End Sub

Sub すべてのオプション欄のクリア()
    Application.ScreenUpdating = False

    Dim sheetNames As Variant
    Dim i As Integer
    Dim ws As Worksheet

    ' 部材シートのオプション欄クリア
    sheetNames = Array(SHEET_N_SASHI, SHEET_N_TATEGU, SHEET_N_SETUBI, SHEET_N_ZATSU, _
                       SHEET_B_SASHI, SHEET_B_TATEGU, SHEET_B_SETUBI, SHEET_B_ZATSU, _
                       SHEET_A_SASHI, SHEET_A_TATEGU, SHEET_A_SETUBI, SHEET_A_ZATSU)
    For i = LBound(sheetNames) To UBound(sheetNames)
        On Error Resume Next
        Set ws = ThisWorkbook.Sheets(sheetNames(i))

        If Not ws Is Nothing Then
            On Error Resume Next
            Dim tblF As ListObject
            Dim defaultCategoryName As String
            Set tblF = ws.ListObjects(ws.Name & "F")
            defaultCategoryName = Range(ws.Range("B2").Value & "Fカテゴリ名").Value

            If Not tblF Is Nothing Then
                tblF.DataBodyRange.ClearContents

                Dim colCategory As Integer
                colCategory = tblF.ListColumns("カテゴリ").Index
                tblF.DataBodyRange.Columns(colCategory).Value = defaultCategoryName
            End If
            On Error GoTo 0
        End If

        On Error GoTo 0
    Next i

    Application.ScreenUpdating = True
End Sub


Sub 諸経費シートのクリア()
    Application.ScreenUpdating = False

    Dim ws As Worksheet

    ' 諸経費シートのクリア
    Set ws = ThisWorkbook.Sheets(SHEET_SHOKEIHI)
    ' 諸経費テーブルの「項目」「数量」「金額」列をクリア
    Dim tbl As ListObject
    Dim colItem As Integer, colQty As Integer, colAmount As Integer, colTotal As Integer
    On Error Resume Next
    Set tbl = ws.ListObjects(ws.Name)
    On Error GoTo 0

    If Not tbl Is Nothing Then
        On Error Resume Next
        colItem = tbl.ListColumns("項目").Index
        colQty = tbl.ListColumns("数量").Index
        colAmount = tbl.ListColumns("金額").Index
        On Error GoTo 0

        tbl.DataBodyRange.Columns(colItem).ClearContents
        tbl.DataBodyRange.Columns(colQty).ClearContents
        tbl.DataBodyRange.Columns(colAmount).ClearContents

    End If

    Application.ScreenUpdating = True
End Sub

Sub 基本入力のE列クリア()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Dim i As Long
    Set ws = ThisWorkbook.Sheets(SHEET_KIHON)
    For i = 1 To 100
        If ws.Cells(i, "B").Value = 1 Then
            ws.Cells(i, "E").ClearContents
        End If
    Next i

    For i = 1 To 100
        If ws.Cells(i, "L").Value = 1 Then
            ws.Cells(i, "N").ClearContents
        End If
    Next i

    Application.ScreenUpdating = True
End Sub

Sub ファイルを別名保存()

    If MsgBox("ファイルを別名で保存します。同じ名前のファイルがある場合は上書きされます。よろしいですか？", vbYesNo + vbQuestion, "確認") = vbNo Then
        Exit Sub
    End If

    ' まずは保存
    ThisWorkbook.Save

    Dim folderPath As String
    Dim koujiName As String
    Dim dt As String
    Dim saveFileName As String

    ' 保存先フォルダ（現在のブックと同じ場所）
    folderPath = ThisWorkbook.Path & "\"

    ' 工事名取得
    koujiName = Range("工事名").Value
    If koujiName = "" Then
        MsgBox "工事名が入力されていません。", vbExclamation
        Exit Sub
    End If

    ' 日時取得（yyyyMMdd-HHMMSS形式）
    ' dt = Format(Now, "yyyymmdd-HHMMSS")
    dt = Format(Now, "yyyymmdd")

    ' ファイル名作成
    saveFileName = folderPath & "マトリックス積算" & " " & koujiName & " 見積書" & dt & ".xlsm"

    ' 別名で保存
    On Error GoTo SaveError
    'ThisWorkbook.SaveAs fileName:=saveFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    ThisWorkbook.SaveCopyAs fileName:=saveFileName
    On Error GoTo 0
    GoTo SaveEnd

SaveError:
    MsgBox "ファイルの保存に失敗しました。同じ名前のファイルが開かれていないか確認してください。" & vbCrLf & "ファイル名: " & saveFileName, vbExclamation
    Exit Sub

SaveEnd:

    MsgBox "ファイルを保存しました。" & vbCrLf & saveFileName, vbInformation
End Sub

Sub シート保護と非表示処理()
    Dim ws As Worksheet
    Dim pwd As String
    pwd = ThisWorkbook.Sheets(SHEET_KIHON).Range("Z10000").Value

    Application.ScreenUpdating = False

    ' 全シートをパスワードで保護
    For Each ws In ThisWorkbook.Worksheets
        ws.Protect Password:=pwd, UserInterfaceOnly:=True
    Next ws

    ' 指定以外のシートを非表示
    Call 指定以外のシートを非表示

    Application.ScreenUpdating = True
End Sub

Sub シート保護解除()
    Dim ws As Worksheet
    Dim pwd As String
    pwd = ThisWorkbook.Sheets(SHEET_KIHON).Range("Z10000").Value

    Application.ScreenUpdating = False

    For Each ws In ThisWorkbook.Worksheets
        ws.Unprotect Password:=pwd
    Next ws

    Application.ScreenUpdating = True
    Call 基本入力シートに戻る
    ActiveSheet.Range("E4").Select
End Sub

Sub 指定以外のシートを非表示()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> SHEET_MITSUMORI And ws.Name <> SHEET_MEISAI And ws.Name <> SHEET_KIHON And ws.Name <> SHEET_SHOKEIHI Then
            ws.Visible = xlSheetHidden
        Else
            ws.Visible = xlSheetVisible
        End If
    Next ws

    Call 基本入力シートに戻る
    ActiveSheet.Range("E4").Select
End Sub

Sub すべてのシートを表示するマクロ()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        ws.Visible = xlSheetVisible
    Next ws

    Application.ScreenUpdating = True
    Call 基本入力シートに戻る
    ActiveSheet.Range("E4").Select
End Sub

Sub テーブル並び順ソート()
    Application.ScreenUpdating = False

    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim sortCol As ListColumn

    Set ws = ActiveSheet
    On Error Resume Next
    Set tbl = ws.ListObjects(ws.Name)
    On Error GoTo 0

    If tbl Is Nothing Then
        MsgBox "シート名と同じテーブルが見つかりません。", vbExclamation
        Exit Sub
    End If

    Set sortCol = Nothing
    On Error Resume Next
    Set sortCol = tbl.ListColumns("並び順")
    On Error GoTo 0

    If sortCol Is Nothing Then
        MsgBox "「並び順」列が見つかりません。", vbExclamation
        Exit Sub
    End If

    With tbl.Sort
        .SortFields.Clear
        .SortFields.Add key:=sortCol.DataBodyRange, Order:=xlAscending
        .Header = xlYes
        .Apply
    End With

    Application.ScreenUpdating = True
    MsgBox "並び順でソートが完了しました。", vbInformation
End Sub

Function 必須入力チェック結果() As Boolean
    Dim ws As Worksheet
    Dim i As Long
    Set ws = ThisWorkbook.Sheets(SHEET_KIHON)

    For i = 1 To 100
        If ws.Cells(i, "F").Value = "※" Then
            If ws.Cells(i, "E").Value = "" Then
                ws.Activate
                ws.Cells(i, "E").Select
                MsgBox "「" & ws.Cells(i, "C").Value & "」が未入力です。", vbExclamation
                必須入力チェック結果 = False
                Exit Function
            End If
        End If
    Next i
    必須入力チェック結果 = True
End Function

Sub パターン別一括設定_ガス仕様()
    Call パターン別一括設定("ガス仕様")
End Sub

Sub パターン別一括設定_電気仕様()
    Call パターン別一括設定("電気仕様")
End Sub

Sub パターン別一括設定_ZEH仕様()
    Call パターン別一括設定("ZEH仕様")
End Sub

Sub パターン別一括設定(ByVal pattern As String)
    Application.ScreenUpdating = False

    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim colPattern As Integer, colQty As Integer
    Dim r As Long

    Set ws = ActiveSheet
    On Error Resume Next
    Set tbl = ws.ListObjects(ws.Name)
    On Error GoTo 0
    If tbl Is Nothing Then
        MsgBox "シート名と同じテーブルが見つかりません。", vbExclamation
        Exit Sub
    End If

    colPattern = 0
    colQty = 0
    On Error Resume Next
    colPattern = tbl.ListColumns(pattern).Index
    colQty = tbl.ListColumns("数量").Index
    On Error GoTo 0

    If colPattern = 0 Or colQty = 0 Then
        MsgBox "「数量」列または「" & pattern & "」列が見つかりません。", vbExclamation
        Exit Sub
    End If
    
    ' すでに数量が入力されている場合は加算・マージする
    Dim rowCount As Long
    rowCount = tbl.DataBodyRange.Rows.Count
    For r = 1 To rowCount
        Dim currentQty As Variant
        Dim patternQty As Variant
        currentQty = tbl.DataBodyRange(r, colQty).Value
        patternQty = tbl.DataBodyRange(r, colPattern).Value
        If IsNumeric(patternQty) And patternQty <> "" Then
            If IsNumeric(currentQty) And currentQty <> "" Then
                tbl.DataBodyRange(r, colQty).Value = currentQty + patternQty
            Else
                tbl.DataBodyRange(r, colQty).Value = patternQty
            End If
        End If
    Next r
    
    Application.ScreenUpdating = True
End Sub

Sub 商品名列範囲を非表示()
    Application.ScreenUpdating = False

    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim colProduct As Integer
    Dim lastRow As Long, freeItemRow As Long
    Dim i As Long

    Set ws = ActiveSheet
    On Error Resume Next
    Set tbl = ws.ListObjects(ws.Name)
    On Error GoTo 0
    If tbl Is Nothing Then
        MsgBox "シート名と同じテーブルが見つかりません。", vbExclamation
        Exit Sub
    End If

    On Error Resume Next
    colProduct = tbl.ListColumns("商品名").Index
    On Error GoTo 0
    If colProduct = 0 Then
        MsgBox "「商品名」列が見つかりません。", vbExclamation
        Exit Sub
    End If

    On Error Resume Next
    ws.Rows.Hidden = False
    On Error GoTo 0

    lastRow = tbl.DataBodyRange.Rows.Count + tbl.HeaderRowRange.Row + 1
    freeItemRow = 0

    For i = tbl.HeaderRowRange.Row To ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
        If ws.Cells(i, "B").Value = "オプション欄" Then
            freeItemRow = i
            Exit For
        End If
    Next i

    If freeItemRow = 0 Then
        MsgBox "「オプション欄」が見つかりません。", vbExclamation
        Exit Sub
    End If

    If lastRow + 1 < freeItemRow - 1 Then
        ws.Rows((lastRow + 1) & ":" & (freeItemRow - 2)).Hidden = True
    End If

    Application.ScreenUpdating = True
        
    ws.Cells(freeItemRow + 2, "B").Select

    
End Sub

Sub すべてのシートボタン文字色一括変更()
    Dim ws As Worksheet
    Dim shp As Shape
    Dim btn As Object
    Dim targetColor As Long
    targetColor = RGB(0, 0, 0)

    For Each ws In ThisWorkbook.Worksheets
        ' Formコントロールボタン
        For Each shp In ws.Shapes
            If shp.Type = msoFormControl Then
                If shp.FormControlType = xlButtonControl Then
                    shp.TextFrame.Characters.Font.Color = targetColor
                End If
            End If
        Next shp
        ' ActiveXコントロールボタン
        For Each btn In ws.OLEObjects
            If TypeName(btn.Object) = "CommandButton" Then
                btn.Object.ForeColor = targetColor
            End If
        Next btn
    Next ws
End Sub