307 lines
9.2 KiB
QBasic
307 lines
9.2 KiB
QBasic
Attribute VB_Name = "Module1"
|
||
Option Explicit
|
||
|
||
Sub 減坪単価更新マクロ()
|
||
|
||
Dim resp As VbMsgBoxResult
|
||
resp = MsgBox("減坪単価リストを更新します。よろしいですか？", vbYesNo + vbQuestion, "確認")
|
||
If resp <> vbYes Then Exit Sub
|
||
|
||
Application.ScreenUpdating = False
|
||
' 対象ファイルのパスを取得
|
||
Dim fileName As String
|
||
fileName = Dir(ThisWorkbook.FullName)
|
||
Dim folderPath As String
|
||
folderPath = Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - Len(fileName))
|
||
Dim targetFileName As String
|
||
targetFileName = Range("更新対象ファイル").Value
|
||
Dim targetFilePath As String
|
||
targetFilePath = folderPath & targetFileName
|
||
|
||
If Dir(targetFilePath) = "" Then
|
||
MsgBox "対象ファイルが見つかりません: " & targetFilePath, vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
Dim wb As Workbook
|
||
Dim isOpened As Boolean
|
||
isOpened = False
|
||
For Each wb In Workbooks
|
||
If wb.FullName = targetFilePath Then
|
||
isOpened = True
|
||
Exit For
|
||
End If
|
||
Next wb
|
||
|
||
If Not isOpened Then
|
||
MsgBox "対象ファイルは開かれていません: " & targetFilePath, vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
' 対象ファイルの減坪単価シートの「減坪単価テーブル」を取得
|
||
Dim wsGenTsubo As Worksheet
|
||
Dim ws As Worksheet
|
||
Dim tbl As ListObject
|
||
Dim tblGenTsubo As ListObject
|
||
|
||
Set wsGenTsubo = Nothing
|
||
For Each ws In Workbooks(targetFileName).Worksheets
|
||
If ws.Name = "減坪単価" Then
|
||
Set wsGenTsubo = ws
|
||
Exit For
|
||
End If
|
||
Next ws
|
||
|
||
If wsGenTsubo Is Nothing Then
|
||
MsgBox "減坪単価シートが見つかりません。", vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
Set tblGenTsubo = Nothing
|
||
For Each tbl In wsGenTsubo.ListObjects
|
||
Debug.Print tbl.Name
|
||
If tbl.Name = "減坪テーブル" Then
|
||
Set tblGenTsubo = tbl
|
||
Exit For
|
||
End If
|
||
Next tbl
|
||
|
||
If tblGenTsubo Is Nothing Then
|
||
MsgBox "減坪テーブルが見つかりません。", vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
' ここに更新処理を記述
|
||
Dim lastRow As Long
|
||
Dim i As Long
|
||
Dim srcWs As Worksheet
|
||
Dim srcRange As Range
|
||
|
||
Set srcWs = ThisWorkbook.Worksheets("減坪単価")
|
||
lastRow = srcWs.Cells(srcWs.Rows.Count, "N").End(xlUp).Row
|
||
|
||
For i = 8 To lastRow
|
||
Dim findVal As Variant
|
||
findVal = srcWs.Cells(i, "N").Value
|
||
|
||
Dim tblRow As ListRow
|
||
Set tblRow = Nothing
|
||
|
||
' テーブルの1列目で一致する行を検索
|
||
Dim r As ListRow
|
||
For Each r In tblGenTsubo.ListRows
|
||
If r.Range.Cells(1, 1).Value = findVal Then
|
||
Set tblRow = r
|
||
Exit For
|
||
End If
|
||
Next r
|
||
|
||
If Not tblRow Is Nothing Then
|
||
' T列までの値をテーブルに転記
|
||
Dim colOffset As Integer
|
||
For colOffset = 0 To 8 ' N(14)～W(22) = 9列
|
||
tblRow.Range.Cells(1, colOffset + 1).Value = srcWs.Cells(i, 14 + colOffset).Value
|
||
Next colOffset
|
||
End If
|
||
Next i
|
||
|
||
Application.ScreenUpdating = True
|
||
Workbooks(targetFileName).Save
|
||
MsgBox "減坪単価の更新が完了しました。", vbInformation
|
||
End Sub
|
||
|
||
Sub マトリックス更新マクロ()
|
||
Dim brand As String
|
||
Dim kaisu As String
|
||
brand = ActiveSheet.Range("C2").Value
|
||
kaisu = ActiveSheet.Range("C3").Value
|
||
|
||
Dim resp As VbMsgBoxResult
|
||
resp = MsgBox(brand & " " & kaisu & " のマトリックス金額を更新します。よろしいですか？", vbYesNo + vbQuestion, "確認")
|
||
If resp <> vbYes Then
|
||
Exit Sub
|
||
End If
|
||
|
||
Application.ScreenUpdating = False
|
||
|
||
' キー取得
|
||
Dim key As Variant
|
||
key = ActiveSheet.Range("C4").Value
|
||
|
||
' ファイルパス取得
|
||
Dim fileName As String
|
||
fileName = Dir(ThisWorkbook.FullName)
|
||
Dim folderPath As String
|
||
folderPath = Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - Len(fileName))
|
||
Dim targetFileName As String
|
||
targetFileName = Range("更新対象ファイル").Value
|
||
Dim targetFilePath As String
|
||
targetFilePath = folderPath & targetFileName
|
||
|
||
If Dir(targetFilePath) = "" Then
|
||
MsgBox "対象ファイルが見つかりません: " & targetFilePath, vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
Dim wb As Workbook
|
||
Dim isOpened As Boolean
|
||
isOpened = False
|
||
For Each wb In Workbooks
|
||
If wb.FullName = targetFilePath Then
|
||
isOpened = True
|
||
Exit For
|
||
End If
|
||
Next wb
|
||
|
||
If Not isOpened Then
|
||
MsgBox "対象ファイルは開かれていません: " & targetFilePath, vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
' 対象ファイルの「マトリックス」シート取得
|
||
Dim wsMatrix As Worksheet
|
||
Set wsMatrix = Workbooks(targetFileName).Worksheets("マトリックス")
|
||
|
||
' 2行目からキー列を検索
|
||
Dim keyCol As Long
|
||
keyCol = 0
|
||
Dim col As Long
|
||
For col = 1 To wsMatrix.Cells(2, wsMatrix.Columns.Count).End(xlToLeft).Column
|
||
If wsMatrix.Cells(2, col).Value = key Then
|
||
keyCol = col
|
||
Exit For
|
||
End If
|
||
Next col
|
||
|
||
If keyCol = 0 Or keyCol <= 2 Then
|
||
MsgBox "キーが見つからないか、列位置が不正です。", vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
' 対象シートの3列分（keyCol-2～keyCol）の6行目から1000行目をクリア
|
||
wsMatrix.Range(wsMatrix.Cells(6, keyCol - 2), wsMatrix.Cells(1000, keyCol)).ClearContents
|
||
' 更新元データ取得（N7:Pまで）
|
||
' Dim srcWs As Worksheet
|
||
' Set srcWs = ActiveSheet
|
||
' Dim srcRow As Long
|
||
' srcRow = 7
|
||
'Do While srcWs.Cells(srcRow, "N").Value <> ""
|
||
' 3列分のデータを転記
|
||
' wsMatrix.Cells(srcRow - 1, keyCol - 2).Value = srcWs.Cells(srcRow, "N").Value
|
||
' wsMatrix.Cells(srcRow - 1, keyCol - 1).Value = srcWs.Cells(srcRow, "O").Value
|
||
' wsMatrix.Cells(srcRow - 1, keyCol).Value = srcWs.Cells(srcRow, "P").Value
|
||
' srcRow = srcRow + 1
|
||
' Loop
|
||
|
||
' 更新元データ取得（N7:Pまで）
|
||
Dim srcWs As Worksheet
|
||
Set srcWs = ActiveSheet
|
||
Dim srcRow As Long
|
||
srcRow = 7
|
||
' ソース元データを2次元配列に格納
|
||
Dim lastSrcRow As Long
|
||
lastSrcRow = srcWs.Cells(srcWs.Rows.Count, "N").End(xlUp).Row
|
||
If lastSrcRow < srcRow Then
|
||
MsgBox "転記するデータがありません。", vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
Dim arrData As Variant
|
||
arrData = srcWs.Range("N" & srcRow & ":P" & lastSrcRow).Value
|
||
|
||
' 転記先範囲に一括挿入
|
||
wsMatrix.Range(wsMatrix.Cells(srcRow - 1, keyCol - 2), wsMatrix.Cells(srcRow - 1 + UBound(arrData, 1) - 1, keyCol)).Value = arrData
|
||
|
||
Application.ScreenUpdating = True
|
||
Workbooks(targetFileName).Save
|
||
MsgBox "マトリックスの更新が完了しました。", vbInformation
|
||
End Sub
|
||
|
||
Sub マトリックス表生成処理()
|
||
Dim resp As VbMsgBoxResult
|
||
resp = MsgBox("このシートのマトリックス表を更新します。よろしいですか？", vbYesNo + vbQuestion, "確認")
|
||
If resp <> vbYes Then
|
||
Exit Sub
|
||
End If
|
||
Application.ScreenUpdating = False
|
||
|
||
Dim ws As Worksheet
|
||
Set ws = ActiveSheet
|
||
|
||
Dim comboCount As Long
|
||
comboCount = ws.Range("J4").Value
|
||
|
||
Dim tbl As ListObject
|
||
Set tbl = Nothing
|
||
Dim t As ListObject
|
||
Dim tableName As String
|
||
tableName = ws.Name & "テーブル"
|
||
For Each t In ws.ListObjects
|
||
If t.Name = tableName Then
|
||
Set tbl = t
|
||
Exit For
|
||
End If
|
||
Next t
|
||
|
||
If tbl Is Nothing Then
|
||
MsgBox "テーブル「" & tableName & "」が見つかりません。", vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
Dim lastNum As Long
|
||
lastNum = 0
|
||
Dim r As ListRow
|
||
Dim delStartRow As Long
|
||
delStartRow = 0
|
||
For Each r In tbl.ListRows
|
||
Dim numVal As Variant
|
||
numVal = r.Range.Cells(1, 1).Value
|
||
If IsNumeric(numVal) Then
|
||
If numVal > lastNum Then
|
||
lastNum = numVal
|
||
End If
|
||
If numVal = comboCount + 1 Then
|
||
delStartRow = r.Index
|
||
End If
|
||
End If
|
||
Next r
|
||
|
||
If comboCount < lastNum Then
|
||
' 余分な行をクリア
|
||
If delStartRow > 0 Then
|
||
tbl.DataBodyRange.Rows(delStartRow & ":" & tbl.ListRows.Count).Delete
|
||
End If
|
||
|
||
Elseif comboCount > lastNum Then
|
||
' 行をコピーして増やす（数式維持、7列目は値の1固定）
|
||
Dim baseRow As ListRow
|
||
Set baseRow = Nothing
|
||
For Each r In tbl.ListRows
|
||
If IsNumeric(r.Range.Cells(1, 1).Value) Then
|
||
If r.Range.Cells(1, 1).Value = lastNum Then
|
||
Set baseRow = r
|
||
Exit For
|
||
End If
|
||
End If
|
||
Next r
|
||
|
||
If Not baseRow Is Nothing Then
|
||
Dim i As Long
|
||
For i = lastNum + 1 To comboCount
|
||
Dim newRow As ListRow
|
||
Set newRow = tbl.ListRows.Add
|
||
baseRow.Range.Copy
|
||
newRow.Range.PasteSpecial xlPasteFormulasAndNumberFormats
|
||
newRow.Range.Cells(1, 1).Value = i
|
||
newRow.Range.Cells(1, 7).Value = 1 ' 7列目は値の1固定
|
||
Next i
|
||
Application.CutCopyMode = False
|
||
End If
|
||
End If
|
||
|
||
Application.ScreenUpdating = True
|
||
ActiveWorkbook.Save
|
||
MsgBox "マトリックス表の更新が完了しました。", vbInformation
|
||
|
||
End Sub
|