327 lines
10 KiB
Plaintext
327 lines
10 KiB
Plaintext
Option Explicit
|
||
|
||
Sub 明細の抽出()
|
||
If Range("選択ブランド").Value = "" Then
|
||
MsgBox "ブランドが選択されていません。", vbExclamation
|
||
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 destRow As Long, i As Long
|
||
Dim colProduct As Integer, colPrice As Integer, colQty As Integer, colUnit 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
|
||
srcSheetName = Range(categoryName).Value
|
||
srcTableName = Range(categoryName).Value
|
||
|
||
'--- 設定 ---
|
||
Set srcWs = ThisWorkbook.Sheets(srcSheetName)
|
||
Set destWs = ThisWorkbook.Sheets(destSheetName)
|
||
Set srcTbl = srcWs.ListObjects(srcTableName)
|
||
|
||
'列番号取得（列名は実際のものに合わせてください）
|
||
colProduct = srcTbl.ListColumns("商品名").Index
|
||
colPrice = srcTbl.ListColumns("単価").Index
|
||
colUnit = 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
|
||
destWs.Cells(destRow, 3).Value = srcTbl.DataBodyRange(i, colUnit).Value
|
||
destWs.Cells(destRow, 4).Value = srcTbl.DataBodyRange(i, colQty).Value
|
||
destWs.Cells(destRow, 5).Value = srcTbl.DataBodyRange(i, colUnitName).Value
|
||
金額 = srcTbl.DataBodyRange(i, colPrice).Value * srcTbl.DataBodyRange(i, colUnit).Value * srcTbl.DataBodyRange(i, colQty).Value
|
||
destWs.Cells(destRow, 6).Value = 金額
|
||
subtotal = subtotal + 金額
|
||
destRow = destRow + 1
|
||
End If
|
||
Next
|
||
|
||
'--- 小計行（商品名と同じ列に"小計"） ---
|
||
destWs.Cells(destRow, 1).Value = " 小計"
|
||
destWs.Cells(destRow, 6).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 sheetNames As Variant
|
||
Dim i As Integer
|
||
sheetNames = Array("NBサッシ工事", "NB内部建具", "NB設備", "B雑工事", "N雑工事", "Aサッシ工事", "A内部建具", "A設備", "A雑工事")
|
||
For i = LBound(sheetNames) To UBound(sheetNames)
|
||
On Error Resume Next
|
||
ThisWorkbook.Sheets(sheetNames(i)).Visible = xlSheetHidden
|
||
On Error Goto 0
|
||
Next i
|
||
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("基本入力")
|
||
ws.Activate
|
||
ws.Range("A1").Select
|
||
End Sub
|
||
|
||
Sub 見積書シートに移動()
|
||
Dim ws As Worksheet
|
||
Set ws = ThisWorkbook.Sheets("見積書")
|
||
ws.Activate
|
||
ws.Range("A1").Select
|
||
End Sub
|
||
|
||
Sub 明細書シートに移動()
|
||
Dim ws As Worksheet
|
||
Set ws = ThisWorkbook.Sheets("明細書")
|
||
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("F4").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 クリア()
|
||
ActiveSheet.Range("F4:F10000").ClearContents
|
||
End Sub
|
||
|
||
|
||
Sub 見積書明細書PDF出力()
|
||
Dim wsMitsumori As Worksheet, wsMeisai As Worksheet
|
||
Dim pdfFileName As String
|
||
Dim folderPath As String
|
||
Dim mitsumoriNo As String, koujiName As String, issueDate As String
|
||
|
||
Set wsMitsumori = ThisWorkbook.Sheets("見積書")
|
||
Set wsMeisai = ThisWorkbook.Sheets("明細書")
|
||
|
||
' 保存先フォルダ（必要に応じて変更）
|
||
folderPath = ThisWorkbook.Path & "\"
|
||
|
||
' ファイル名用情報取得
|
||
mitsumoriNo = Range("見積書番号").Value
|
||
koujiName = Range("工事名").Value
|
||
issueDate = Range("発行年月日").Value
|
||
|
||
' 日付を"yyyyMMddHHmmss"形式に
|
||
Dim dt As String
|
||
dt = Format(issueDate, "yyyymmdd-HHMMSS")
|
||
|
||
' ファイル名作成
|
||
pdfFileName = folderPath & mitsumoriNo & "■" & koujiName & "■" & dt & ".pdf"
|
||
|
||
' シートを配列で指定してPDF出力
|
||
Sheets(Array("見積書", "明細書")).Select
|
||
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfFileName, Quality:=xlQualityStandard
|
||
|
||
' 元のシートに戻る
|
||
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("明細書")
|
||
|
||
' B列の最終行取得
|
||
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
|
||
|
||
' B2から下方向に「合計」を探す
|
||
合計Row = 0
|
||
Dim i As Long
|
||
For i = 2 To lastRow
|
||
If IsError(ws.Cells(i, "B").Value) Or ws.Cells(i, "B").Value = CVErr(xlErrNA) Then
|
||
Continue For
|
||
End If
|
||
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 + 3
|
||
|
||
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
|
||
Call 基本入力のE列クリア()
|
||
Call 複数シートF列クリア()
|
||
End Sub
|
||
|
||
Sub 複数シートF列クリア()
|
||
Dim sheetNames As Variant
|
||
Dim i As Integer
|
||
Dim ws As Worksheet
|
||
sheetNames = Array("NBサッシ工事", "NB内部建具", "NB設備", "B雑工事", "N雑工事", "Aサッシ工事", "A内部建具", "A設備", "A雑工事")
|
||
For i = LBound(sheetNames) To UBound(sheetNames)
|
||
On Error Resume Next
|
||
Set ws = ThisWorkbook.Sheets(sheetNames(i))
|
||
If Not ws Is Nothing Then
|
||
ws.Range("F4:F10000").ClearContents
|
||
End If
|
||
Set ws = Nothing
|
||
On Error Goto 0
|
||
Next i
|
||
End Sub
|
||
|
||
Sub 基本入力のE列クリア()
|
||
Dim ws As Worksheet
|
||
Dim i As Long
|
||
Set ws = ThisWorkbook.Sheets("基本入力")
|
||
For i = 1 To 100
|
||
If ws.Cells(i, "B").Value = 1 Then
|
||
ws.Cells(i, "E").ClearContents
|
||
End If
|
||
Next i
|
||
End Sub
|
||
|
||
Sub ファイルを別名保存()
|
||
Dim folderPath As String
|
||
Dim koujiName As String
|
||
Dim dt As String
|
||
Dim saveFileName As String
|
||
|
||
' 保存先フォルダ（現在のブックと同じ場所）
|
||
folderPath = ThisWorkbook.Path & "\"
|
||
|
||
' 工事名取得
|
||
koujiName = Range("工事名").Value
|
||
|
||
' 日時取得（yyyyMMdd-HHMMSS形式）
|
||
dt = Format(Now, "yyyymmdd-HHMMSS")
|
||
|
||
' ファイル名作成
|
||
saveFileName = folderPath & "nBAH積算システム" & "■" & koujiName & "■" & dt & ".xlsm"
|
||
|
||
' 別名で保存
|
||
ThisWorkbook.SaveAs Filename:=saveFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
|
||
|
||
MsgBox "ファイルを保存しました。" & vbCrLf & saveFileName, vbInformation
|
||
End Sub |