853 lines
27 KiB
QBasic
853 lines
27 KiB
QBasic
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
|
||
End Sub
|
||
|
||
|
||
' filepath: c:\Users\k.nogi\#GitHub\ken_nogi\pleasanter\develop\##実行予算承認WF\sites\scripts\抽出マクロ.vbs
|
||
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 金額 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)
|
||
|
||
'列番号取得（列名は実際のものに合わせてください）
|
||
colProduct = srcTbl.ListColumns("商品名").Index
|
||
colPrice = srcTbl.ListColumns("単価").Index
|
||
colQty = srcTbl.ListColumns("数量").Index
|
||
colUnitName = 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
|
||
|
||
'--- カテゴリ名・ヘッダー出力 ---
|
||
destWs.Cells(destRow, 1).Value = categoryName
|
||
destRow = destRow + 1
|
||
|
||
subtotal = 0
|
||
|
||
'--- データ抽出と金額計算 ---
|
||
For i = 1 To srcTbl.ListRows.Count
|
||
If srcTbl.DataBodyRange(i, colQty).Value > 0 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 = 金額
|
||
subtotal = subtotal + 金額
|
||
destRow = destRow + 1
|
||
End If
|
||
Next i
|
||
|
||
For i = 1 To srcTblF.ListRows.Count
|
||
If srcTblF.DataBodyRange(i, colQty).Value > 0 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 = 金額
|
||
subtotal = subtotal + 金額
|
||
destRow = destRow + 1
|
||
End If
|
||
Next i
|
||
|
||
'--- 雑工事の場合、減坪金額を調べて追記 ---
|
||
If categoryName = "雑工事" Then
|
||
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 = 金額
|
||
subtotal = subtotal + 金額
|
||
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 = 金額
|
||
subtotal = subtotal + 金額
|
||
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 = 金額
|
||
subtotal = subtotal + 金額
|
||
destRow = destRow + 1
|
||
End If
|
||
|
||
End If
|
||
|
||
|
||
'--- 小計行（商品名と同じ列に"小計"） ---
|
||
destWs.Cells(destRow, 1).Value = " 小計"
|
||
destWs.Cells(destRow, 5).Value = subtotal
|
||
|
||
'MsgBox "抽出と金額計算が完了しました", vbInformation
|
||
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")
|
||
|
||
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 = ws.Range("B2").Value
|
||
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
|
||
Set tblF = ws.ListObjects(ws.Name & "F")
|
||
If Not tblF Is Nothing Then
|
||
tblF.DataBodyRange.ClearContents
|
||
|
||
Dim colCategory As Integer
|
||
colCategory = tblF.ListColumns("カテゴリ").Index
|
||
tblF.DataBodyRange.Columns(colCategory).Value = ws.Range("B2").Value
|
||
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
|
||
|
||
tbl.DataBodyRange.Columns(colQty).Value = tbl.DataBodyRange.Columns(colPattern).Value
|
||
|
||
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
|
||
|