update Generic Master bas5

This commit is contained in:
updsv7
2026-04-15 15:16:14 +09:00
parent 5e906f3300
commit 63d09d78a7
6 changed files with 339 additions and 247 deletions

View File

@@ -22,6 +22,116 @@ Function GetLastDataRow(ByVal ws As Worksheet, ByVal columnNum As Long) As Long
GetLastDataRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row GetLastDataRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row
End Function End Function
' @return dict : key = keyColvalue = Array
' @param sheetName
' @param keyCol
' @param valueCols Array(4,5,6)
' @param startRow default is 7
Function LoadLookup( _
ByVal sheetName As String, _
ByVal keyCol As Long, _
ByVal valueCols As Variant, _
Optional ByVal startRow As Long = 7 _
) As Object
' --- validate ---
If Trim(sheetName) = "" Then Exit Function
If Not IsArray(valueCols) Then
valueCols = Array(valueCols)
End If
Dim nValCols As Long: nValCols = UBound(valueCols) - LBound(valueCols) + 1
If nValCols = 0 Then Exit Function
' --- obtain worksheet ---
On Error Resume Next
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(sheetName)
On Error GoTo 0
If ws Is Nothing Then Exit Function
' --- obtain databased on keyCol---
Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, keyCol).End(xlUp).Row
If lastRow < startRow Then Exit Function
' --- prepare col ---
Dim minCol As Long: minCol = keyCol
Dim maxCol As Long: maxCol = keyCol
Dim i As Long
For i = LBound(valueCols) To UBound(valueCols)
If Not IsNumeric(valueCols(i)) Then Exit Function
Dim colNum As Long: colNum = CLng(valueCols(i))
If colNum < 1 Then Exit Function
If colNum < minCol Then minCol = colNum
If colNum > maxCol Then maxCol = colNum
Next i
' --- read ---
Dim dataRange As Range
Set dataRange = ws.Range(ws.Cells(startRow, minCol), ws.Cells(lastRow, maxCol))
Dim data As Variant: data = dataRange.Value
' --- Ensure data is a 2D array ---
If Not IsArray(data) Then
' Single cell case
Dim temp As Variant
ReDim temp(1 To 1, 1 To (maxCol - minCol + 1))
temp(1, 1) = data
data = temp
End If
' --- build ---
Dim keyOffset As Long: keyOffset = keyCol - minCol + 1
Dim valOffsets() As Long: ReDim valOffsets(0 To nValCols - 1)
For i = 0 To nValCols - 1
valOffsets(i) = valueCols(LBound(valueCols) + i) - minCol + 1
Next i
' --- write into ---
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long
For r = 1 To UBound(data, 1)
Dim key As String: key = Trim(data(r, keyOffset))
If key <> "" Then
Dim vals() As String: ReDim vals(0 To nValCols - 1)
Dim j As Long
For j = 0 To nValCols - 1
vals(j) = Trim(data(r, valOffsets(j)))
Next j
dict(key) = vals
End If
Next r
Set LoadLookup = dict
End Function
Function GetLastDataRowInRange(ws As Worksheet, ByVal startCol As Long, ByVal endCol As Long, Optional ByVal startRow As Long = 7) As Long
' --- validate ---
If startCol < 1 Then
Err.Raise 1001, "GetLastDataRowInRange", "startCol must >= 1"
End If
If endCol < 1 Then
Err.Raise 1002, "GetLastDataRowInRange", "endCol must >= 1"
End If
If endCol < startCol Then
Err.Raise 1003, "GetLastDataRowInRange", "endCol must >= startCol"
End If
If startRow < 1 Then
Err.Raise 1004, "GetLastDataRowInRange", "startRow must >= 1"
End If
' --- query max row ---
Dim colIndex As Long, lastRow As Long, maxRow As Long
maxRow = startRow - 1
For colIndex = startCol To endCol
lastRow = ws.Cells(ws.Rows.Count, colIndex).End(xlUp).Row
If lastRow > maxRow Then maxRow = lastRow
Next colIndex
GetLastDataRowInRange = maxRow
End Function
Sub ClearDataRows(ByVal ws As Worksheet, ByVal startRow As Long, ByVal columnNum As Long) Sub ClearDataRows(ByVal ws As Worksheet, ByVal startRow As Long, ByVal columnNum As Long)
Dim lastRow As Long Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row lastRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row

View File

@@ -1,189 +1,143 @@
' CSV Header Constants ' ====== (222) =======
' ====== Constants ======
Const START_COL As Long = 3
Const END_COL As Long = 14
Private z1Cache As Object '
' ====== Function ======
Public Sub RefreshZ1Cache()
Set z1Cache = LoadLookup("Z1", keyCol:=3, valueCols:=Array(4), startRow:=7)
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
For i = 1 To 12
headerArr(1, i) = Trim(ws.Cells(5, i + 2).Value) ' i+2: 1→3(C), 12→14(N)
Next i
GetM1CSVHeader = headerArr
End Function
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 columns when C column changes ===
If Target.Column = 3 And Target.Row >= 7 Then If Target.Column = 4 And Target.Row >= 7 Then
If z1Cache Is Nothing Then Call RefreshZ1Cache
Dim cell As Range Dim cell As Range
For Each cell In Target For Each cell In Target
If Trim(cell.Value) = "" Then Dim dVal As String: dVal = Trim(cell.Value)
Call ClearRowData(Me, cell.Row) If dVal = "" Then
Me.Cells(cell.Row, 5).ClearContents
Else Else
Call FillFromZ1(Me, cell.Row) If Not z1Cache Is Nothing And z1Cache.Exists(dVal) Then
Dim vals As Variant: vals = z1Cache(dVal)
Me.Cells(cell.Row, 5).Value = vals(0)
Else
Me.Cells(cell.Row, 5).ClearContents
End If
End If End If
Next Next
End If End If
End Sub End Sub
Sub FillFromZ1(ByVal ws As Worksheet, ByVal rowNum As Long, Optional ByVal setG As Boolean = True) Sub FillFromZ1(ByVal rowNum As Long)
Dim wsZ1 As Worksheet Dim ws As Worksheet: Set ws = ActiveSheet
Dim lastRow As Long Dim code As String: code = Trim(ws.Cells(rowNum, 3).Value)
Dim i As Long If code = "" Then
Dim code As String Call ClearRowData(ws, rowNum)
Exit Sub
On Error Resume Next End If
Set wsZ1 = ThisWorkbook.Worksheets("Z1")
If wsZ1 Is Nothing Then Exit Sub If z1Cache Is Nothing Then Call RefreshZ1Cache
On Error GoTo 0 If z1Cache Is Nothing Then Exit Sub
code = Trim(ws.Cells(rowNum, 3).Value)
If code = "" Then Exit Sub If z1Cache.Exists(code) Then
lastRow = wsZ1.Cells(wsZ1.rows.Count, 3).End(xlUp).Row Dim vals As Variant: vals = z1Cache(code)
For i = 7 To lastRow ws.Cells(rowNum, 4).Value = vals(0)
If Trim(wsZ1.Cells(i, 7).Value) = code Then ws.Cells(rowNum, 5).Value = vals(1)
ws.Cells(rowNum, 4).Value = Trim(wsZ1.Cells(i, 4).Value) Else
ws.Cells(rowNum, 4).Value = Trim(wsZ1.Cells(i, 4).Value) Call ClearRowData(ws, rowNum)
ws.Cells(rowNum, 5).Value = Trim(wsZ1.Cells(i, 6).Value) End If
ws.Cells(rowNum, 6).Value = Trim(wsZ1.Cells(i, 7).Value)
ws.Cells(rowNum, 7).Value = Trim(wsZ1.Cells(i, 9).Value)
If setG Then
ws.Cells(rowNum, 7).Value = "1"
End If
Exit Sub
End If
Next
Call ClearRowData(ws, rowNum)
End Sub End Sub
Sub ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long) Sub ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long)
' Clear from D column onwards ' Clear columns D onwards
ws.Range(ws.Cells(rowNum, 4), ws.Cells(rowNum, 15)).ClearContents ws.Range(ws.Cells(rowNum, 4), ws.Cells(rowNum, 15)).ClearContents
ws.Cells(rowNum, 6).Validation.Delete ws.Cells(rowNum, 6).Validation.Delete
ws.Cells(rowNum, 19).ClearContents ' Q column error info ws.Cells(rowNum, 19).ClearContents ' Column Q - error info
End Sub End Sub
Sub M1_Import() Sub M1_Import()
Dim filePath As String
Dim fileDialog As fileDialog
Dim wsTarget As Worksheet Dim wsTarget As Worksheet
Dim stream As Object Dim csvData As Variant
Dim textContent As String
Dim lines As Variant
Dim i As Long Dim i As Long
Dim dataArray As Variant Dim writeRow As Long
Dim code As String
Dim lastRow As Long
Dim r As Long
' Target this worksheet ' Target this worksheet
Set wsTarget = Me Set wsTarget = Me
' === Step 1: Select CSV file === ' === Step 1: Select CSV file ===
Set fileDialog = Application.fileDialog(msoFileDialogFilePicker) Dim filePath As String
With fileDialog filePath = SelectCSVFile()
.Filters.Clear If filePath = "" Then Exit Sub
.Filters.Add "CSV Files", "*.csv"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
filePath = .SelectedItems(1)
End With
' === Step 2: Read CSV with Shift-JIS === ' === Step 2: Read CSV with Shift-JIS (using common function) ===
Set stream = CreateObject("ADODB.Stream") On Error GoTo ImportError
With stream csvData = ReadCSVAs2DArrayStrict(filePath, 12, "shift_jis", False)
.Type = 2 On Error GoTo 0
.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 === ' === Clear all data rows before import ===
lastRow = wsTarget.Cells(wsTarget.rows.Count, "C").End(xlUp).Row Dim lastRow As Long
lastRow = wsTarget.Cells(wsTarget.Rows.Count, "C").End(xlUp).Row
If lastRow >= 7 Then If lastRow >= 7 Then
wsTarget.Range("A7:P" & lastRow).ClearContents wsTarget.Range("A7:N" & lastRow).ClearContents
End If End If
If UBound(lines) < 1 Then If UBound(csvData, 1) < 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: Write CSV data to worksheet (forward order) ===
Dim csvData As Object
Set csvData = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(lines)
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 writeRow = 7
For i = 1 To UBound(lines) For i = LBound(csvData, 1) To UBound(csvData, 1)
If Trim(lines(i)) = "" Then GoTo NextLine ' CSV col 1-12 -> C-N column
Dim j As Long
For j = 1 To 12
wsTarget.Cells(writeRow, j + 2).Value = CleanCSVField(CStr(csvData(i, j)))
Next j
dataArray = Split(lines(i), ",") ' Auto-fill D, E columns from Z1
' Call FillFromZ1(wsTarget, writeRow, False)
' CSV col 1 -> C column
code = CleanCSVField(CStr(dataArray(0))) writeRow = writeRow +
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
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
Sub validate(ByVal ws As Worksheet, ByVal rowNum As Long) Sub validate(ByVal rowNum As Long)
Set ws = Me
' Check C column not empty ' Check C column not empty
If Trim(ws.Cells(rowNum, 3).Value) = "" Then If Trim(ws.Cells(rowNum, 3).Value) = "" Then
ws.Cells(rowNum, 19).ClearContents ws.Cells(rowNum, 19).ClearContents
Exit Sub Exit Sub
End If End If
' Check G, H required and numeric (for composite key) ' Check G (column 9), H (column 10) required and numeric (for composite key)
If Trim(ws.Cells(rowNum, 9).Value) = "" Or Not IsNumeric(ws.Cells(rowNum, 9).Value) Then If Trim(ws.Cells(rowNum, 9).Value) = "" Or Not IsNumeric(ws.Cells(rowNum, 9).Value) Then
ws.Cells(rowNum, 19).Value = "G column (I) is required and must be numeric" ws.Cells(rowNum, 19).Value = "G column (I) is required and must be numeric"
Exit Sub Exit Sub
@@ -194,13 +148,13 @@ Sub validate(ByVal ws As Worksheet, ByVal rowNum As Long)
Exit Sub Exit Sub
End If End If
' Check I (K column) required ' Check I (column 11) required
If Trim(ws.Cells(rowNum, 11).Value) = "" Then If Trim(ws.Cells(rowNum, 11).Value) = "" Then
ws.Cells(rowNum, 19).Value = "I column (K) is required" ws.Cells(rowNum, 19).Value = "I column (K) is required"
Exit Sub Exit Sub
End If End If
' Check J, K required and numeric ' Check J (column 12), K (column 13) required and numeric
If Trim(ws.Cells(rowNum, 12).Value) = "" Or Not IsNumeric(ws.Cells(rowNum, 12).Value) Then 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" ws.Cells(rowNum, 19).Value = "J column (L) is required and must be numeric"
Exit Sub Exit Sub
@@ -211,7 +165,7 @@ Sub validate(ByVal ws As Worksheet, ByVal rowNum As Long)
Exit Sub Exit Sub
End If End If
' Check L-P optional but must be numeric if entered ' Check L-P (columns 14-18) optional but must be numeric if entered
Dim col As Long Dim col As Long
Dim colName As String Dim colName As String
Dim colLetter As String Dim colLetter As String
@@ -225,7 +179,7 @@ Sub validate(ByVal ws As Worksheet, ByVal rowNum As Long)
End If End If
Next col Next col
' Check GH composite key duplicate ' Check G-H composite key for duplicates
Dim g As String, h As String Dim g As String, h As String
Dim r As Long Dim r As Long
Dim lastRow As Long Dim lastRow As Long
@@ -233,7 +187,7 @@ Sub validate(ByVal ws As Worksheet, ByVal rowNum As Long)
g = Trim(ws.Cells(rowNum, 9).Value) g = Trim(ws.Cells(rowNum, 9).Value)
h = Trim(ws.Cells(rowNum, 10).Value) h = Trim(ws.Cells(rowNum, 10).Value)
lastRow = ws.Cells(ws.rows.Count, 3).End(xlUp).Row lastRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
For r = 7 To lastRow For r = 7 To lastRow
If r <> rowNum And Trim(ws.Cells(r, 3).Value) = Trim(ws.Cells(rowNum, 3).Value) Then If r <> rowNum And Trim(ws.Cells(r, 3).Value) = Trim(ws.Cells(rowNum, 3).Value) Then
@@ -244,20 +198,19 @@ Sub validate(ByVal ws As Worksheet, ByVal rowNum As Long)
End If End If
Next r Next r
' Validation passed ' Validation passed - clear error
ws.Cells(rowNum, 19).ClearContents ws.Cells(rowNum, 19).ClearContents
End Sub End Sub
' Button macro (Validate selected row)
Sub validateButton() Sub validateButton()
Dim ws As Worksheet Dim ws As Worksheet
Dim lastRow As Long Dim lastRow As Long
Dim r As Long Dim r As Long
Dim errorCount As Long Dim errorCount As Long
Set ws = ActiveSheet Set ws = Me
lastRow = ws.Cells(ws.rows.Count, "C").End(xlUp).Row lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
If lastRow < 7 Then If lastRow < 7 Then
MsgBox "No data found.", vbExclamation MsgBox "No data found.", vbExclamation
@@ -266,81 +219,110 @@ Sub validateButton()
errorCount = 0 errorCount = 0
For r = 7 To lastRow For r = 7 To lastRow
Call validateDetailData(ws, r) Call validate(ws, r)
If Trim(ws.Cells(r, 17).Value) <> "" Then If Trim(ws.Cells(r, 19).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 M1_Export() Sub M1_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 ws As Worksheet
Set ws = Me
Dim savePath As String ' === Step 1: Validate all rows before export ===
savePath = Application.GetSaveAsFilename( _ Dim r As Long, errorCount As Long
FileFilter:="CSV Files (*.csv), *.csv", _
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 If Len(Trim(ws.Cells(r, 3).Value & "")) > 0 Then
rowCount = rowCount + 1 Call validate(ws, r)
' CSV col1 -> C column If Trim(ws.Cells(r, 19).Value) <> "" Then
csvContent = csvContent & CleanCSVField(ws.Cells(r, 3).Value) errorCount = errorCount + 1
' CSV col2-11 -> I-R column End If
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
Set stream = CreateObject("ADODB.Stream") savePath = GetSaveCSVPath()
stream.Type = 2 If savePath = "" Then Exit Sub
stream.Charset = "shift_jis"
stream.Open ' === Step 3: Get header from row 5 (C-N columns) ===
stream.WriteText csvContent, 1 Dim headerArr As Variant
stream.SaveToFile savePath, 2 headerArr = GetM1CSVHeader(ws)
stream.Close
' === Step 4: Build data array (skip D, E, F columns) ===
Dim dataArr As Variant
Dim rowCount As Long
rowCount = 0
For r = 7 To lastDataRow
If Len(Trim(ws.Cells(r, 3).Value & "")) > 0 Then
rowCount = rowCount + 1
End If
Next r
If rowCount = 0 Then
MsgBox "No data rows to output.", vbExclamation
Exit Sub
End If
ReDim dataArr(1 To rowCount, 1 To 12)
Dim dataRow As Long
dataRow = 0
For r = 7 To lastDataRow
If Len(Trim(ws.Cells(r, 3).Value & "")) > 0 Then
dataRow = dataRow + 1
' CSV col1 -> C column
dataArr(dataRow, 1) = CleanCSVField(ws.Cells(r, 3).Value)
' CSV col2-12 -> G-N column (columns 7-14)
Dim j As Long
For j = 7 To 14
dataArr(dataRow, j - 6) = CleanCSVField(ws.Cells(r, j).Value)
Next j
End If
Next r
' === Step 5: Write to CSV (using common function) ===
Dim outputArr As Variant
ReDim outputArr(1 To rowCount + 1, 1 To 12)
' Copy header to first row
Dim colIdx As Long
For colIdx = 1 To 12
outputArr(1, colIdx) = headerArr(1, colIdx)
Next colIdx
' Copy data to remaining rows
Dim dataR As Long
For dataR = 1 To rowCount
For colIdx = 1 To 12
outputArr(dataR + 1, colIdx) = dataArr(dataR, colIdx)
Next colIdx
Next dataR
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 End Sub
Sub M1_SortDataRowsByC() Sub M1_SortDataRowsByC()

View File

@@ -1,4 +1,10 @@
' ====== (222) ======= ' ====== (222) =======
' ====== Constants ======
Const START_COL As Long = 3
Const END_COL As Long = 9
' ====== Function ======
Sub Z1_ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long) Sub Z1_ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long)
Call Generic_Master_ClearRowData(ws, rowNum) Call Generic_Master_ClearRowData(ws, rowNum)
End Sub End Sub
@@ -8,15 +14,14 @@ Sub Z1_Import()
End Sub End Sub
Sub Z1_Export() Sub Z1_Export()
Dim lastDataRow As Long: lastDataRow = GetLastDataRow(Me, 3) Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
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 r As Long Dim r As Long, errorCount As Long
Dim errorCount As Long
For r = 7 To lastDataRow For r = 7 To lastDataRow
Validate r Validate r
If Trim(Cells(r, 2).Value & "") <> "" Then If Trim(Cells(r, 2).Value & "") <> "" Then
@@ -33,14 +38,12 @@ Sub Z1_Export()
End Sub End Sub
Sub Validate(ByVal rowNum As Long) Sub Validate(ByVal rowNum As Long)
Dim cValue As String
Set ws = Me Set ws = Me
Dim cValue As String: cValue = Trim(ws.Cells(rowNum, 3).Value)
cValue = Trim(ws.Cells(rowNum, 3).Value)
' clear C~I columns background color ' clear C~I columns background color
Dim clearRange As Range Dim clearRange As Range
Set clearRange = ws.Range(ws.Cells(rowNum, 3), ws.Cells(rowNum, 9)) Set clearRange = ws.Range(ws.Cells(rowNum, START_COL), ws.Cells(rowNum, END_COL))
clearRange.Interior.Color = vbWhite clearRange.Interior.Color = vbWhite
If cValue = "" Then If cValue = "" Then
@@ -135,19 +138,16 @@ Sub Validate(ByVal rowNum As Long)
End Sub End Sub
Sub Z1_validateButton() Sub Z1_validateButton()
Dim lastRow As Long Dim lastDataRow As Long, r As Long, errorCount As Long
Dim r As Long lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
Dim errorCount As Long
lastRow = GetLastDataRow(Me, 3) If lastDataRow < 7 Then
If lastRow < 7 Then
MsgBox "No data found.", vbExclamation MsgBox "No data found.", vbExclamation
Exit Sub Exit Sub
End If End If
errorCount = 0 errorCount = 0
For r = 7 To lastRow For r = 7 To lastDataRow
Validate r Validate r
If Trim(Cells(r, 2).Value) <> "" Then If Trim(Cells(r, 2).Value) <> "" Then
errorCount = errorCount + 1 errorCount = errorCount + 1
@@ -166,5 +166,5 @@ Sub Z1_ToggleAutoFilter()
End Sub End Sub
Sub Z1_AutoFitColumnWidth() Sub Z1_AutoFitColumnWidth()
Call AutoFitColumnWidth(2, 9) Call AutoFitColumnWidth(2, END_COL)
End Sub End Sub

View File

@@ -1,4 +1,10 @@
' ====== (223) ======= ' ====== (223) =======
' ====== Constants ======
Const START_COL As Long = 3
Const END_COL As Long = 7
' ====== Function ======
Sub Z2_ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long) Sub Z2_ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long)
Call Generic_Master_ClearRowData(ws, rowNum) Call Generic_Master_ClearRowData(ws, rowNum)
End Sub End Sub
@@ -8,15 +14,14 @@ Sub Z2_Import()
End Sub End Sub
Sub Z2_Export() Sub Z2_Export()
Dim lastDataRow As Long: lastDataRow = GetLastDataRow(Me, 3) Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
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 r As Long Dim r As Long, errorCount As Long
Dim errorCount As Long
For r = 7 To lastDataRow For r = 7 To lastDataRow
Validate r Validate r
If Trim(Cells(r, 2).Value & "") <> "" Then If Trim(Cells(r, 2).Value & "") <> "" Then
@@ -33,14 +38,12 @@ Sub Z2_Export()
End Sub End Sub
Sub Validate(ByVal rowNum As Long) Sub Validate(ByVal rowNum As Long)
Dim cValue As String
Set ws = Me Set ws = Me
Dim cValue As String: cValue = Trim(ws.Cells(rowNum, 3).Value)
cValue = Trim(ws.Cells(rowNum, 3).Value)
' clear C~I columns background color ' clear C~I columns background color
Dim clearRange As Range Dim clearRange As Range
Set clearRange = ws.Range(ws.Cells(rowNum, 3), ws.Cells(rowNum, 7)) Set clearRange = ws.Range(ws.Cells(rowNum, START_COL), ws.Cells(rowNum, END_COL))
clearRange.Interior.Color = vbWhite clearRange.Interior.Color = vbWhite
If cValue = "" Then If cValue = "" Then
@@ -119,19 +122,16 @@ Sub Validate(ByVal rowNum As Long)
End Sub End Sub
Sub Z2_validateButton() Sub Z2_validateButton()
Dim lastRow As Long Dim lastDataRow As Long, r As Long, errorCount As Long
Dim r As Long lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
Dim errorCount As Long
lastRow = GetLastDataRow(Me, 3) If lastDataRow < 7 Then
If lastRow < 7 Then
MsgBox "No data found.", vbExclamation MsgBox "No data found.", vbExclamation
Exit Sub Exit Sub
End If End If
errorCount = 0 errorCount = 0
For r = 7 To lastRow For r = 7 To lastDataRow
Validate r Validate r
If Trim(Cells(r, 2).Value) <> "" Then If Trim(Cells(r, 2).Value) <> "" Then
errorCount = errorCount + 1 errorCount = errorCount + 1
@@ -150,5 +150,5 @@ Sub Z2_ToggleAutoFilter()
End Sub End Sub
Sub Z2_AutoFitColumnWidth() Sub Z2_AutoFitColumnWidth()
Call AutoFitColumnWidth(2, 7) Call AutoFitColumnWidth(2, END_COL)
End Sub End Sub

View File

@@ -1,4 +1,10 @@
' ====== (224) ======= ' ====== (224) =======
' ====== Constants ======
Const START_COL As Long = 3
Const END_COL As Long = 8
' ====== Function ======
Sub Z3_ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long) Sub Z3_ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long)
Call Generic_Master_ClearRowData(ws, rowNum) Call Generic_Master_ClearRowData(ws, rowNum)
End Sub End Sub
@@ -8,15 +14,14 @@ Sub Z3_Import()
End Sub End Sub
Sub Z3_Export() Sub Z3_Export()
Dim lastDataRow As Long: lastDataRow = GetLastDataRow(Me, 3) Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
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 r As Long Dim r As Long, errorCount As Long
Dim errorCount As Long
For r = 7 To lastDataRow For r = 7 To lastDataRow
Validate r Validate r
If Trim(Cells(r, 2).Value & "") <> "" Then If Trim(Cells(r, 2).Value & "") <> "" Then
@@ -33,14 +38,12 @@ Sub Z3_Export()
End Sub End Sub
Sub Validate(ByVal rowNum As Long) Sub Validate(ByVal rowNum As Long)
Dim cValue As String
Set ws = Me Set ws = Me
Dim cValue As String: cValue = Trim(ws.Cells(rowNum, 3).Value)
cValue = Trim(ws.Cells(rowNum, 3).Value)
' clear C~I columns background color ' clear C~I columns background color
Dim clearRange As Range Dim clearRange As Range
Set clearRange = ws.Range(ws.Cells(rowNum, 3), ws.Cells(rowNum, 8)) Set clearRange = ws.Range(ws.Cells(rowNum, START_COL), ws.Cells(rowNum, END_COL))
clearRange.Interior.Color = vbWhite clearRange.Interior.Color = vbWhite
If cValue = "" Then If cValue = "" Then
@@ -127,19 +130,16 @@ Sub Validate(ByVal rowNum As Long)
End Sub End Sub
Sub Z3_validateButton() Sub Z3_validateButton()
Dim lastRow As Long Dim lastDataRow As Long, r As Long, errorCount As Long
Dim r As Long lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
Dim errorCount As Long
If lastDataRow < 7 Then
lastRow = GetLastDataRow(Me, 3)
If lastRow < 7 Then
MsgBox "No data found.", vbExclamation MsgBox "No data found.", vbExclamation
Exit Sub Exit Sub
End If End If
errorCount = 0 errorCount = 0
For r = 7 To lastRow For r = 7 To lastDataRow
Validate r Validate r
If Trim(Cells(r, 2).Value) <> "" Then If Trim(Cells(r, 2).Value) <> "" Then
errorCount = errorCount + 1 errorCount = errorCount + 1
@@ -158,5 +158,5 @@ Sub Z3_ToggleAutoFilter()
End Sub End Sub
Sub Z3_AutoFitColumnWidth() Sub Z3_AutoFitColumnWidth()
Call AutoFitColumnWidth(2, 8) Call AutoFitColumnWidth(2, END_COL)
End Sub End Sub