updsv7/vba
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

m2 update

Browse Source
This commit is contained in:
updsv7
2026-04-16 14:22:11 +09:00
parent a2ea02f36d
commit c39b8da85e
6 changed files with 255 additions and 317 deletions
Download Patch File Download Diff File Expand all files Collapse all files

20
src/data/区間詳細.csv Normal file
View File

@@ -0,0 +1,20 @@
利用区間コード,券種,コード,名称,1箇月運賃/販売額,定期額/券１(額)/利用額,定期支給期間/券１(枚)/特別料金,特別料金/券２(額),券２(枚),端数(額),特別料金
00001,1,003,６箇月定期,7920,47520,6,,,,
00001,2,001,テスト,15000,0,0,0,0,0,
00001,3,001,プリペイドカード,20000,20000,,,,,
00002,1,003,６箇月定期,1451.833,8711,6,,,,
00002,2,001,テスト,15000,0,0,0,0,0,
00002,3,002,0002テスト,45000,60000,,,,,
00003,2,002,テスト2,500,500,10,500,10,0,
00004,3,003,0004テスト,5000,5000,,,,,
00005,1,003,６箇月定期,4753.333,28520,6,,,,
00006,1,001,１箇月定期,7920,7920,1,,,,
00006,1,003,６箇月定期,7920,47520,6,,,,
00021,1,001,１箇月定期,6260,6260,1,,,,
00038,1,001,１箇月定期,6260,6260,1,,,,
00056,1,003,６箇月定期,10030,10030,1,,,,
00067,1,003,６箇月定期,4486.666,26920,6,,,,
00068,1,003,６箇月定期,52800,316800,6,,,,
00069,1,006,６箇月,7181.666,43090,6,,,,
00070,1,003,６箇月定期,6426.666,38560,6,,,,
00071,1,003,６箇月定期,6879,6879,1,,,,
1 利用区間コード 券種 コード 名称 1箇月運賃/販売額 定期額/券１(額)/利用額 定期支給期間/券１(枚)/特別料金 特別料金/券２(額) 券２(枚) 端数(額) 特別料金
2 00001 1 003 ６箇月定期 7920 47520 6
3 00001 2 001 テスト 15000 0 0 0 0 0
4 00001 3 001 プリペイドカード 20000 20000
5 00002 1 003 ６箇月定期 1451.833 8711 6
6 00002 2 001 テスト 15000 0 0 0 0 0
7 00002 3 002 0002テスト 45000 60000
8 00003 2 002 テスト2 500 500 10 500 10 0
9 00004 3 003 0004テスト 5000 5000
10 00005 1 003 ６箇月定期 4753.333 28520 6
11 00006 1 001 １箇月定期 7920 7920 1
12 00006 1 003 ６箇月定期 7920 47520 6
13 00021 1 001 １箇月定期 6260 6260 1
14 00038 1 001 １箇月定期 6260 6260 1
15 00056 1 003 ６箇月定期 10030 10030 1
16 00067 1 003 ６箇月定期 4486.666 26920 6
17 00068 1 003 ６箇月定期 52800 316800 6
18 00069 1 006 ６箇月 7181.666 43090 6
19 00070 1 003 ６箇月定期 6426.666 38560 6
20 00071 1 003 ６箇月定期 6879 6879 1

23
src/module/Module_Common.bas
View File

@@ -2,6 +2,25 @@
' Common Functions ' Common Functions
' ============================================================ ' ============================================================
' Get CSV header from specified row and columns
Function GetCSVHeader(ByVal ws As Worksheet, ByVal colLetters As Variant, ByVal headerRow As Long) As Variant
Dim colCount As Long: colCount = UBound(colLetters) - LBound(colLetters) + 1
Dim headerArr() As String
ReDim headerArr(1 To 1, 1 To colCount)
Dim i As Long
Dim cellValue As String
For i = 0 To colCount - 1
cellValue = Trim(ws.Cells(headerRow, Columns(colLetters(i)).Column).Value)
cellValue = Replace(cellValue, vbLf, "")
cellValue = Replace(cellValue, vbCr, "")
cellValue = Replace(cellValue, vbCrLf, "")
headerArr(1, i + 1) = cellValue
Next i
GetCSVHeader = headerArr
End Function
Function CleanCSVField(ByVal inputStr As String) As String Function CleanCSVField(ByVal inputStr As String) As String
Dim s As String Dim s As String
s = Trim(inputStr) s = Trim(inputStr)
@@ -145,7 +164,9 @@ Function ClearDataRows(ByVal ws As Worksheet, ByVal startCol As Long, ByVal endC
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws, startCol, endCol, startRow) Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws, startCol, endCol, startRow)
If lastDataRow >= startRow Then If lastDataRow >= startRow Then
ws.Range(ws.Cells(startRow, startCol), ws.Cells(lastDataRow, endCol)).ClearContents Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(startRow, startCol), ws.Cells(lastDataRow, endCol))
clearRange.ClearContents
clearRange.Interior.Color = vbWhite
End If End If
End Function End Function

10
src/module/Read_Common.bas
View File

@@ -49,7 +49,7 @@ Function ReadCSVAs2DArrayStrict( _
.Close .Close
End With End With
' === stardand === ' === standardize ===
textContent = Replace(textContent, vbCrLf, vbLf) textContent = Replace(textContent, vbCrLf, vbLf)
textContent = Replace(textContent, vbCr, vbLf) textContent = Replace(textContent, vbCr, vbLf)
@@ -135,6 +135,10 @@ Private Function ParseCSVLines(ByVal csvText As String) As Collection
currentField = currentField & c currentField = currentField & c
i = i + 1 i = i + 1
Else Else
' Clean field before adding
currentField = Trim(currentField)
currentField = Replace(currentField, vbCr, "")
currentField = Replace(currentField, vbLf, "")
currentRow.Add currentField currentRow.Add currentField
currentField = "" currentField = ""
i = i + 1 i = i + 1
@@ -167,6 +171,10 @@ Private Function ParseCSVLines(ByVal csvText As String) As Collection
' Handle last row without trailing newline ' Handle last row without trailing newline
If currentField <> "" Or currentRow.Count > 0 Then If currentField <> "" Or currentRow.Count > 0 Then
' Clean field before adding
currentField = Trim(currentField)
currentField = Replace(currentField, vbCr, "")
currentField = Replace(currentField, vbLf, "")
currentRow.Add currentField currentRow.Add currentField
Dim lastArr() As String Dim lastArr() As String
If currentRow.Count > 0 Then If currentRow.Count > 0 Then

64
src/thisWorkbook/Master_M1_Kukan.bas
View File

@@ -1,13 +1,16 @@
' ====== (222) =======
' ====== Constants ====== ' ====== Constants ======
Const START_COL As Long = 3 ' C column Const START_COL As Long = 3 ' C column
Const END_COL As Long = 14 ' N column Const END_COL As Long = 14 ' N column
Const ERROR_COL As Long = 15 ' O column Const ERROR_COL As Long = 15 ' O column
Const M1_HEADER_ROW As Long = 5
Private z1Cache As Object ' Z1 cache Private z1Cache As Object ' Z1 cache
Private enumCache As Object ' Z1 cache Private enumCache As Object ' Z1 cache
Function HEADERS() As Variant
HEADERS = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N")
End Function
' ====== Function ====== ' ====== Function ======
Public Sub RefreshZ1Cache() Public Sub RefreshZ1Cache()
On Error GoTo RefreshError On Error GoTo RefreshError
@@ -67,23 +70,6 @@ Private Sub CreateEnumDropdown(ByVal rowNum As Long)
End Sub End Sub
' Get CSV header from row 5 (columns C to N)
Function GetM1CSVHeader(ByVal ws As Worksheet) As Variant
Dim headerArr(1 To 1, 1 To 12) As String
Dim i As Long
Dim cellValue As String
For i = 1 To 12
cellValue = Trim(ws.Cells(5, i + 2).Value) ' i+2: 1→3(C), 12→14(N)
' Remove line breaks
cellValue = Replace(cellValue, vbLf, "")
cellValue = Replace(cellValue, vbCr, "")
cellValue = Replace(cellValue, vbCrLf, "")
headerArr(1, i) = cellValue
Next i
GetM1CSVHeader = headerArr
End Function
Private Sub Worksheet_Change(ByVal Target As Range) Private Sub Worksheet_Change(ByVal Target As Range)
' === Column C changes: Create L column dropdown === ' === Column C changes: Create L column dropdown ===
@@ -121,11 +107,8 @@ Private Sub Worksheet_Change(ByVal Target As Range)
End Sub End Sub
Sub M1_Import() Sub M1_Import()
Dim wsTarget As Worksheet: Set wsTarget = Me
' === Step 1: Select CSV file === ' === Step 1: Select CSV file ===
Dim filePath As String Dim filePath As String: filePath = SelectCSVFile()
filePath = SelectCSVFile()
If filePath = "" Then Exit Sub If filePath = "" Then Exit Sub
' === Step 2: Read CSV with Shift-JIS (using common function) === ' === Step 2: Read CSV with Shift-JIS (using common function) ===
@@ -137,19 +120,22 @@ Sub M1_Import()
MsgBox "No data in CSV.", vbExclamation MsgBox "No data in CSV.", vbExclamation
Exit Sub Exit Sub
End If End If
' === Step 3:Clear all data rows before import === ' === Step 3:Clear all data rows before import ===
Application.EnableEvents = False Application.EnableEvents = False
Dim wsTarget As Worksheet: Set wsTarget = Me
Call ClearDataRows(wsTarget, START_COL, END_COL, 7) Call ClearDataRows(wsTarget, START_COL, END_COL, 7)
Application.EnableEvents = True Application.EnableEvents = True
' === Step 3: Write CSV data to worksheet (forward order) === ' === Step 4: Write CSV data to worksheet ===
Dim i As Long Dim colLetters As Variant: colLetters = HEADERS()
Dim writeRow As Long: writeRow = 7 Dim writeRow As Long: writeRow = 7
Dim i As Long
For i = LBound(csvData, 1) To UBound(csvData, 1) For i = LBound(csvData, 1) To UBound(csvData, 1)
' CSV col 1-12 -> C-N column ' CSV col 1-12 -> C-N column
Dim j As Long Dim j As Long
For j = 1 To 12 For j = 0 To 11
wsTarget.Cells(writeRow, j + 2).Value = CleanCSVField(CStr(csvData(i, j))) wsTarget.Cells(writeRow, Columns(colLetters(j)).Column).Value = CleanCSVField(CStr(csvData(i, j + 1)))
Next j Next j
writeRow = writeRow + 1 writeRow = writeRow + 1
Next i Next i
@@ -268,10 +254,8 @@ Sub M1_Export()
Exit Sub Exit Sub
End If End If
Dim ws As Worksheet
Set ws = Me
' === Step 1: Validate all rows before export === ' === Step 1: Validate all rows before export ===
Dim ws As Worksheet: Set ws = Me
Dim r As Long, errorCount As Long Dim r As Long, errorCount As Long
For r = 7 To lastDataRow For r = 7 To lastDataRow
Call validate(r, lastDataRow) Call validate(r, lastDataRow)
@@ -286,8 +270,7 @@ Sub M1_Export()
End If End If
' === Step 2: Select save path === ' === Step 2: Select save path ===
Dim savePath As String Dim savePath As String: savePath = GetSaveCSVPath()
savePath = GetSaveCSVPath()
If savePath = "" Then Exit Sub If savePath = "" Then Exit Sub
' === Step 3: Count data rows === ' === Step 3: Count data rows ===
@@ -295,22 +278,23 @@ Sub M1_Export()
' === Step 4: Build array with header and data === ' === Step 4: Build array with header and data ===
Dim headerArr As Variant Dim headerArr As Variant
headerArr = GetM1CSVHeader(ws) Dim colLetters As Variant: colLetters = HEADERS()
headerArr = GetCSVHeader(ws, colLetters, M1_HEADER_ROW)
Dim outputArr As Variant Dim outputArr As Variant
ReDim outputArr(1 To rowCount + 1, 1 To 12) ReDim outputArr(1 To rowCount + 1, 1 To 12)
' Row 1: header ' Row 1: header
Dim colIdx As Long Dim colIdx As Long
For colIdx = 1 To 12 For colIdx = 0 To 11
outputArr(1, colIdx) = headerArr(1, colIdx) outputArr(1, colIdx + 1) = headerArr(1, colIdx + 1)
Next colIdx Next colIdx
' Rows 2+: data (C-N columns) ' Rows 2+: data (C-N columns)
Dim dataRow As Long: dataRow = 2 Dim dataRow As Long: dataRow = 2
For r = 7 To lastDataRow For r = 7 To lastDataRow
For colIdx = 1 To 12 For colIdx = 0 To 11
outputArr(dataRow, colIdx) = CleanCSVField(ws.Cells(r, colIdx + 2).Value) outputArr(dataRow, colIdx + 1) = CleanCSVField(ws.Cells(r, Columns(colLetters(colIdx)).Column).Value)
Next colIdx Next colIdx
dataRow = dataRow + 1 dataRow = dataRow + 1
Next r Next r

455
src/thisWorkbook/Master_M2_Kukan_detail.bas
View File

@@ -1,5 +1,30 @@
' CSV Header Constants ' ====== Constants ======
Const CSV_HEADER As String = "利用区間コード,券種,コード,名称,1箇月運賃/販売額,定期額/券１(額)/利用額,定期支給期間/券１(枚)/特別料金,特別料金/券２(額),券２(枚),端数(額),特別料金" Const START_COL As Long = 3 ' C column
Const END_COL As Long = 18 ' R column
Const ERROR_COL As Long = 19 ' S column
Const M2_HEADER_ROW As Long = 6
Private m1Cache As Object ' M1 cache
Function HEADERS() As Variant
HEADERS = Array("C", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R")
End Function
' ====== Function ======
Public Sub RefreshM1Cache()
On Error GoTo RefreshError
Set m1Cache = LoadLookup("M1", keyCol:=3, valueCols:=Array(4), startRow:=7)
On Error GoTo 0
If m1Cache Is Nothing Or m1Cache.Count = 0 Then
Err.Raise 1001, "RefreshM1Cache", "M1 reference data is empty"
End If
Exit Sub
RefreshError:
Err.Raise 1002, "RefreshM1Cache", "Failed to load M1 lookup cache: " & Err.Description
End Sub
Private Sub Worksheet_Change(ByVal Target As Range) Private Sub Worksheet_Change(ByVal Target As Range)
' === Fill D, E when C column changes === ' === Fill D, E when C column changes ===
@@ -9,13 +34,13 @@ Private Sub Worksheet_Change(ByVal Target As Range)
If Trim(cell.Value) = "" Then If Trim(cell.Value) = "" Then
Call ClearRowData(Me, cell.Row) Call ClearRowData(Me, cell.Row)
Else Else
Call FillFromKukanMaster(Me, cell.Row) Call FillFromM1(Me, cell.Row)
End If End If
Next Next
End If End If
End Sub End Sub
Sub FillFromKukanMaster(ByVal ws As Worksheet, ByVal rowNum As Long, Optional ByVal setG As Boolean = True) Sub FillFromM1(ByVal ws As Worksheet, ByVal rowNum As Long, Optional ByVal setG As Boolean = True)
Dim wsKukan As Worksheet Dim wsKukan As Worksheet
Dim lastRow As Long Dim lastRow As Long
Dim i As Long Dim i As Long
@@ -54,310 +79,190 @@ Sub ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long)
ws.Cells(rowNum, 19).ClearContents ' Q column error info ws.Cells(rowNum, 19).ClearContents ' Q column error info
End Sub End Sub
Sub ImportMasterDetailData() Sub M2_Import()
Dim filePath As String
Dim fileDialog As FileDialog
Dim wsTarget As Worksheet
Dim stream As Object
Dim textContent As String
Dim lines As Variant
Dim i As Long
Dim dataArray As Variant
Dim code As String
Dim lastRow As Long
Dim r As Long
' Target this worksheet
Set wsTarget = Me
' === Step 1: Select CSV file === ' === Step 1: Select CSV file ===
Set fileDialog = Application.FileDialog(msoFileDialogFilePicker) Dim filePath As String: filePath = SelectCSVFile()
With fileDialog If filePath = "" Then Exit Sub
.Filters.Clear
.Filters.Add "CSV Files", "*.csv" ' === Step 2: Read CSV with Shift-JIS (using common function) ===
.AllowMultiSelect = False On Error GoTo ImportError
If .Show <> -1 Then Exit Sub Dim csvData As Variant: csvData = ReadCSVAs2DArrayStrict(filePath, 11, "shift_jis", True)
filePath = .SelectedItems(1) On Error GoTo 0
End With
If UBound(csvData, 1) < 1 Then
' === Step 2: Read CSV with Shift-JIS ===
Set stream = CreateObject("ADODB.Stream")
With stream
.Type = 2
.Charset = "shift_jis"
.Open
.LoadFromFile filePath
textContent = .ReadText
.Close
End With
lines = Split(textContent, vbLf)
' === Validate CSV header ===
If UBound(lines) >= 0 And Trim(lines(0)) <> "" Then
Dim csvHeader As String
csvHeader = Trim(lines(0))
' Validate column count
Dim expectedCount As Long
expectedCount = UBound(Split(CSV_HEADER, ",")) + 1
Dim headerFields As Variant
headerFields = Split(csvHeader, ",")
If UBound(headerFields) + 1 <> expectedCount Then
MsgBox "CSV column count mismatch. Expected: " & expectedCount & ", Got: " & UBound(headerFields) + 1, vbExclamation
Exit Sub
End If
End If
' === Clear all data rows before import ===
lastRow = wsTarget.Cells(wsTarget.Rows.Count, "C").End(xlUp).Row
If lastRow >= 7 Then
wsTarget.Range("A7:P" & lastRow).ClearContents
End If
If UBound(lines) < 1 Then
MsgBox "No data in CSV.", vbExclamation MsgBox "No data in CSV.", vbExclamation
Exit Sub Exit Sub
End If End If
' === Step 3: Collect CSV codes and data === ' === Step 3:Clear all data rows before import ===
Dim csvData As Object Application.EnableEvents = False
Set csvData = CreateObject("Scripting.Dictionary") Dim wsTarget As Worksheet: Set wsTarget = Me
Call ClearDataRows(wsTarget, START_COL, ERROR_COL, 7)
For i = 1 To UBound(lines) Application.EnableEvents = True
If Trim(lines(i)) = "" Then GoTo NextCsvLine
dataArray = Split(lines(i), ",")
If UBound(dataArray) >= 0 Then
code = CleanCSVField(CStr(dataArray(0)))
If code <> "" Then
' Use unique key: code + "_" + row index to avoid duplicate key error
csvData.Add code & "_" & i, dataArray
End If
End If
NextCsvLine:
Next i
If csvData.Count = 0 Then
MsgBox "No valid code found.", vbExclamation
Exit Sub
End If
' === Step 6: Write CSV data to next available row ===
writeRow = 7
For i = 1 To UBound(lines)
If Trim(lines(i)) = "" Then GoTo NextLine
dataArray = Split(lines(i), ",")
' CSV col 1 -> C column
code = CleanCSVField(CStr(dataArray(0)))
wsTarget.Cells(writeRow, 3).Value = code
' CSV col 2-11 -> G-P column
If UBound(dataArray) >= 1 Then wsTarget.Cells(writeRow, 9).Value = CleanCSVField(CStr(dataArray(1)))
If UBound(dataArray) >= 2 Then wsTarget.Cells(writeRow, 10).Value = CleanCSVField(CStr(dataArray(2)))
If UBound(dataArray) >= 3 Then wsTarget.Cells(writeRow, 11).Value = CleanCSVField(CStr(dataArray(3)))
If UBound(dataArray) >= 4 Then wsTarget.Cells(writeRow, 12).Value = CleanCSVField(CStr(dataArray(4)))
If UBound(dataArray) >= 5 Then wsTarget.Cells(writeRow, 13).Value = CleanCSVField(CStr(dataArray(5)))
If UBound(dataArray) >= 6 Then wsTarget.Cells(writeRow, 14).Value = CleanCSVField(CStr(dataArray(6)))
If UBound(dataArray) >= 7 Then wsTarget.Cells(writeRow, 15).Value = CleanCSVField(CStr(dataArray(7)))
If UBound(dataArray) >= 8 Then wsTarget.Cells(writeRow, 16).Value = CleanCSVField(CStr(dataArray(8)))
If UBound(dataArray) >= 9 Then wsTarget.Cells(writeRow, 17).Value = CleanCSVField(CStr(dataArray(9)))
If UBound(dataArray) >= 10 Then wsTarget.Cells(writeRow, 18).Value = CleanCSVField(CStr(dataArray(10)))
' Auto-fill D, E columns
Call FillFromKukanMaster(wsTarget, writeRow, False)
' G column has value → trigger F dropdown
' === Step 4: Write CSV data to worksheet ===
Dim colLetters As Variant: colLetters = HEADERS()
Dim writeRow As Long: writeRow = 7
Dim i As Long
For i = LBound(csvData, 1) To UBound(csvData, 1)
' CSV col 1-11 -> C, I-R column
Dim j As Long
For j = 0 To 10
wsTarget.Cells(writeRow, Columns(colLetters(j)).Column).Value = CleanCSVField(CStr(csvData(i, j + 1)))
Next j
writeRow = writeRow + 1 writeRow = writeRow + 1
NextLine:
Next i Next i
MsgBox writeRow - 7 & " rows imported.", vbInformation MsgBox writeRow - 7 & " rows imported.", vbInformation
Exit Sub
ImportError:
MsgBox "CSV import failed: " & Err.Description, vbExclamation
End Sub End Sub
Function CleanCSVField(ByVal field As Variant) As String Sub validate(ByVal rowNum As Long, ByVal lastDataRow As Long)
If IsEmpty(field) Or IsNull(field) Then Set ws = Me
CleanCSVField = ""
Exit Function
End If
Dim result As String
result = Trim(CStr(field))
If Len(result) >= 2 Then
If Left(result, 1) = """" And Right(result, 1) = """" Then
result = Mid(result, 2, Len(result) - 2)
result = Replace(result, """""", """")
End If
End If
CleanCSVField = result
End Function
Sub validateDetailData(ByVal ws As Worksheet, ByVal rowNum As Long) Dim clearRange As Range
' Check C column not empty Set clearRange = ws.Range(ws.Cells(rowNum, START_COL), ws.Cells(rowNum, END_COL))
If Trim(ws.Cells(rowNum, 3).Value) = "" Then clearRange.Interior.Color = vbWhite
ws.Cells(rowNum, 19).ClearContents
Exit Sub ' Check column required
End If Dim colLetter As Variant
For Each colLetter In Array("C", "I", "J", "K")
' Check G, H required and numeric (for composite key) If Trim(ws.Range(colLetter & rowNum).Value) = "" Then
If Trim(ws.Cells(rowNum, 9).Value) = "" Or Not IsNumeric(ws.Cells(rowNum, 9).Value) Then ws.Cells(rowNum, ERROR_COL).Value = colLetter & " column is required"
ws.Cells(rowNum, 19).Value = "G column (I) is required and must be numeric" ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
Next colLetter
If Trim(ws.Cells(rowNum, 10).Value) = "" Or Not IsNumeric(ws.Cells(rowNum, 10).Value) Then
ws.Cells(rowNum, 19).Value = "H column (J) is required and must be numeric" ' Check column numeric (only if has value)
Exit Sub Dim numericCols As Variant: numericCols = Array("L", "M", "N", "O", "P", "Q", "R")
End If Dim col As Variant
For Each col In numericCols
' Check I (K column) required Dim val As String: val = Trim(ws.Range(col & rowNum).Value & "")
If Trim(ws.Cells(rowNum, 11).Value) = "" Then If val <> "" And Not IsNumeric(val) Then
ws.Cells(rowNum, 19).Value = "I column (K) is required" ws.Cells(rowNum, ERROR_COL).Value = col & " column must be numeric"
Exit Sub ws.Range(col & rowNum).Interior.Color = RGB(255, 0, 0)
End If
' Check J, K required and numeric
If Trim(ws.Cells(rowNum, 12).Value) = "" Or Not IsNumeric(ws.Cells(rowNum, 12).Value) Then
ws.Cells(rowNum, 19).Value = "J column (L) is required and must be numeric"
Exit Sub
End If
If Trim(ws.Cells(rowNum, 13).Value) = "" Or Not IsNumeric(ws.Cells(rowNum, 13).Value) Then
ws.Cells(rowNum, 19).Value = "K column (M) is required and must be numeric"
Exit Sub
End If
' Check L-P optional but must be numeric if entered
Dim col As Long
Dim colName As String
Dim colLetter As String
colLetter = "NOPQR"
For col = 14 To 18
If Trim(ws.Cells(rowNum, col).Value) <> "" And Not IsNumeric(ws.Cells(rowNum, col).Value) Then
colName = Mid(colLetter, col - 13, 1)
ws.Cells(rowNum, 19).Value = colName & " column must be numeric"
Exit Sub Exit Sub
End If End If
Next col Next col
' Check GH composite key duplicate ' Check C column in the cache
Dim g As String, h As String If m1Cache Is Nothing Then Call RefreshM1Cache
Dim r As Long Dim dValue As String: dValue = Trim(ws.Range("C" & rowNum).Value)
Dim lastRow As Long
If Not m1Cache.Exists(dValue) Then
g = Trim(ws.Cells(rowNum, 9).Value) ws.Cells(rowNum, ERROR_COL).Value = "C column does not exist in M1."
h = Trim(ws.Cells(rowNum, 10).Value) ws.Range("C" & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
lastRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row End If
For r = 7 To lastRow ' Check I column in the kenshuKbn
If r <> rowNum And Trim(ws.Cells(r, 3).Value) = Trim(ws.Cells(rowNum, 3).Value) Then Dim kenshuKbn As Variant: kenshuKbn = Array("1", "2", "3")
If Trim(ws.Cells(r, 9).Value) = g And Trim(ws.Cells(r, 10).Value) = h Then Dim iValue As String: iValue = Trim(ws.Range("I" & rowNum).Value)
ws.Cells(rowNum, 19).Value = "GH (I,J) combination already exists" If UBound(Filter(kenshuKbn, iValue)) = -1 Then
Exit Sub ws.Cells(rowNum, ERROR_COL).Value = "I column (kenshuKbn) must be 1, 2, or 3"
End If ws.Range("I" & rowNum).Interior.Color = RGB(255, 0, 0)
End If Exit Sub
Next r End If
' Validation passed
ws.Cells(rowNum, 19).ClearContents
End Sub End Sub
' Button macro (Validate selected row) ' Button macro (Validate selected row)
Sub validateDetailDataButton() Sub M2_validateButton()
Dim ws As Worksheet Dim lastDataRow As Long, r As Long, errorCount As Long
Dim lastRow As Long lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
Dim r As Long
Dim errorCount As Long If lastDataRow < 7 Then
Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
If lastRow < 7 Then
MsgBox "No data found.", vbExclamation MsgBox "No data found.", vbExclamation
Exit Sub Exit Sub
End If End If
errorCount = 0 For r = 7 To lastDataRow
For r = 7 To lastRow Validate r, lastDataRow
Call validateDetailData(ws, r) If Trim(Cells(r, ERROR_COL).Value) <> "" Then
If Trim(ws.Cells(r, 17).Value) <> "" Then
errorCount = errorCount + 1 errorCount = errorCount + 1
End If End If
Next r Next r
MsgBox "Validation complete. Errors: " & errorCount & ", ", vbInformation MsgBox "Validation complete. Errors: " & errorCount, vbInformation
End Sub End Sub
Sub ExportMasterDetailData() Sub M2_Export()
Dim ws As Worksheet Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
Set ws = ActiveSheet
Dim lastDataRow As Long
lastDataRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
If lastDataRow < 7 Then If lastDataRow < 7 Then
MsgBox "No data rows to output.", vbExclamation MsgBox "No data rows to output.", vbExclamation
Exit Sub Exit Sub
End If End If
Dim savePath As String ' === Step 1: Validate all rows before export ===
savePath = Application.GetSaveAsFilename( _ Dim ws As Worksheet: Set ws = Me
FileFilter:="CSV Files (*.csv), *.csv", _ Dim r As Long, errorCount As Long
Title:="Save CSV")
If savePath = "False" Then Exit Sub
If InStr(1, savePath, ".csv", vbTextCompare) = 0 Then
savePath = savePath & ".csv"
End If
' Build header from row 5 (columns C, G-P)
Dim csvContent As String
csvContent = Trim(ws.Cells(5, 3).Value)
Dim j As Long
For j = 7 To 16
csvContent = csvContent & "," & Trim(ws.Cells(5, j).Value)
Next j
csvContent = csvContent & vbLf
' Row counter
Dim rowCount As Long
rowCount = 0
' Data: C,G,H,I,J,K,L,M,N,O,P (skip D,E,F)
Dim r As Long
For r = 7 To lastDataRow For r = 7 To lastDataRow
If Len(Trim(ws.Cells(r, 3).Value & "")) > 0 Then Call validate(r, lastDataRow)
rowCount = rowCount + 1 If Trim(ws.Cells(r, ERROR_COL).Value) <> "" Then
' CSV col1 -> C column errorCount = errorCount + 1
csvContent = csvContent & CleanCSVField(ws.Cells(r, 3).Value)
' CSV col2-11 -> I-R column
For j = 9 To 18
csvContent = csvContent & "," & CleanCSVField(ws.Cells(r, j).Value)
Next j
csvContent = csvContent & vbLf
End If End If
Next r Next r
' Trim trailing empty lines If errorCount > 0 Then
Do While Right(csvContent, 1) = vbLf MsgBox "Validation failed. Found " & errorCount & " error(s). Please correct them before exporting.", vbCritical
csvContent = Left(csvContent, Len(csvContent) - 1) Exit Sub
Loop End If
' Write file ' === Step 2: Select save path ===
Dim stream As Object Dim savePath As String: savePath = GetSaveCSVPath()
Set stream = CreateObject("ADODB.Stream") If savePath = "" Then Exit Sub
stream.Type = 2
stream.Charset = "shift_jis" ' === Step 3: Count data rows ===
stream.Open Dim rowCount As Long: rowCount = lastDataRow - 6
stream.WriteText csvContent, 1
stream.SaveToFile savePath, 2 ' === Step 4: Build array with header and data ===
stream.Close Dim headerArr As Variant
Dim colLetters As Variant: colLetters = HEADERS()
headerArr = GetCSVHeader(ws, colLetters, M2_HEADER_ROW)
Dim outputArr As Variant
ReDim outputArr(1 To rowCount + 1, 1 To 11)
' Row 1: header
Dim colIdx As Long
For colIdx = 0 To 10
outputArr(1, colIdx + 1) = headerArr(1, colIdx + 1)
Next colIdx
' Rows 2+: data (C, I-R columns)
Dim dataRow As Long: dataRow = 2
For r = 7 To lastDataRow
For colIdx = 0 To 10
outputArr(dataRow, colIdx + 1) = CleanCSVField(ws.Cells(r, Columns(colLetters(colIdx)).Column).Value)
Next colIdx
dataRow = dataRow + 1
Next r
On Error GoTo ExportError
Call WriteCSVFromArray(savePath, outputArr, "shift_jis", False)
On Error GoTo 0
MsgBox "CSV export completed. Total data rows: " & rowCount, vbInformation MsgBox "CSV export completed. Total data rows: " & rowCount, vbInformation
Exit Sub
ExportError:
MsgBox "CSV export failed: " & Err.Description, vbExclamation
End Sub
Sub M2_SortDataRowsByC()
Call SortDataRows(3)
End Sub
Sub M2_ToggleAutoFilter()
Call ToggleAutoFilter(START_COL, END_COL)
End Sub
Sub M2_AutoFitColumnWidth()
Call AutoFitColumnWidth(START_COL, END_COL)
End Sub End Sub

BIN
通勤手当テンプレート_案.xlsm
View File

Binary file not shown.