rename bas
This commit is contained in:
updsv7
92
src/module/Module_Common.bas
Normal file
92
src/module/Module_Common.bas
Normal file
@@ -0,0 +1,92 @@
|
||||
' ============================================================
|
||||
' Common Functions
|
||||
' ============================================================
|
||||
|
||||
Function CleanCSVField(ByVal inputStr As String) As String
|
||||
Dim s As String
|
||||
s = Trim(inputStr)
|
||||
|
||||
' calcute
|
||||
If Len(s) > 0 Then
|
||||
Select Case Left(s, 1)
|
||||
Case "=", "+", "-", "@"
|
||||
CleanCSVField = "'" & s
|
||||
Exit Function
|
||||
End Select
|
||||
End If
|
||||
|
||||
CleanCSVField = s
|
||||
End Function
|
||||
|
||||
Function GetLastDataRow(ByVal ws As Worksheet, ByVal columnNum As Long) As Long
|
||||
GetLastDataRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row
|
||||
End Function
|
||||
|
||||
Sub ClearDataRows(ByVal ws As Worksheet, ByVal startRow As Long, ByVal columnNum As Long)
|
||||
Dim lastRow As Long
|
||||
lastRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row
|
||||
|
||||
If lastRow >= startRow Then
|
||||
ws.Range(ws.Cells(startRow, 1), ws.Cells(lastRow, 20)).ClearContents
|
||||
End If
|
||||
End Sub
|
||||
|
||||
Sub SortDataRows(Optional ByVal sortColumn As Long = 3)
|
||||
Dim ws As Worksheet
|
||||
Dim lastRow As Long
|
||||
Dim startRow As Long
|
||||
Dim sortOrder As Long
|
||||
|
||||
Set ws = ActiveSheet
|
||||
startRow = 7
|
||||
lastRow = GetLastDataRow(ws, sortColumn)
|
||||
|
||||
If lastRow < startRow Then
|
||||
MsgBox "No data to sort.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' Determine sort order based on first row's current state
|
||||
Dim currentFirst As String
|
||||
Dim nextFirst As String
|
||||
currentFirst = Trim(ws.Cells(startRow, sortColumn).Value)
|
||||
nextFirst = Trim(ws.Cells(startRow + 1, sortColumn).Value)
|
||||
|
||||
If currentFirst <> "" And nextFirst <> "" Then
|
||||
If currentFirst > nextFirst Then
|
||||
sortOrder = xlAscending
|
||||
Else
|
||||
sortOrder = xlDescending
|
||||
End If
|
||||
Else
|
||||
sortOrder = xlAscending
|
||||
End If
|
||||
|
||||
ws.Range(ws.Cells(startRow, 1), ws.Cells(lastRow, 20)).Sort _
|
||||
Key1:=ws.Cells(startRow, sortColumn), _
|
||||
Order1:=sortOrder, _
|
||||
Header:=xlNo
|
||||
End Sub
|
||||
|
||||
Sub ToggleAutoFilter(Optional ByVal filterRow As Long = 6)
|
||||
Dim ws As Worksheet
|
||||
Set ws = ActiveSheet
|
||||
|
||||
' Check if auto filter is already on
|
||||
If ws.AutoFilterMode Then
|
||||
ws.AutoFilterMode = False
|
||||
Else
|
||||
If filterRow >= 1 Then
|
||||
ws.Rows(filterRow).AutoFilter
|
||||
End If
|
||||
End If
|
||||
End Sub
|
||||
|
||||
Sub AutoFitColumnWidth(Optional ByVal fitColumnStart As Long = 2, Optional ByVal fitColumnEnd As Long = 9)
|
||||
Dim ws As Worksheet
|
||||
Set ws = ActiveSheet
|
||||
|
||||
If fitColumnStart <= fitColumnEnd Then
|
||||
ws.Range(ws.Columns(fitColumnStart), ws.Columns(fitColumnEnd)).AutoFit
|
||||
End If
|
||||
End Sub
|
||||
168
src/module/Read_Common.bas
Normal file
168
src/module/Read_Common.bas
Normal file
@@ -0,0 +1,168 @@
|
||||
Function SelectCSVFile() As String
|
||||
Dim fileDialog As FileDialog
|
||||
Set fileDialog = Application.FileDialog(msoFileDialogFilePicker)
|
||||
|
||||
With fileDialog
|
||||
.Filters.Clear
|
||||
.Filters.Add "CSV Files", "*.csv"
|
||||
.AllowMultiSelect = False
|
||||
If .Show <> -1 Then
|
||||
SelectCSVFile = ""
|
||||
Exit Function
|
||||
End If
|
||||
SelectCSVFile = .SelectedItems(1)
|
||||
End With
|
||||
End Function
|
||||
|
||||
' Read a CSV file and return its content as a strict 2D array (1-based).
|
||||
' All rows must have the same number of columns as the first row.
|
||||
' If the file is empty and defaultColumnCount > 0, returns an empty 2D array with zero rows and defaultColumnCount columns.
|
||||
' Parameters:
|
||||
' filePath: Full path to the CSV file.
|
||||
' charset: Text encoding (e.g., "cp932", "utf-8").
|
||||
' defaultColumnCount: Optional. Used only if CSV has no rows. Must be >= 0.
|
||||
Function ReadCSVAs2DArrayStrict( _
|
||||
ByVal filePath As String, _
|
||||
ByVal expectedColumnCount As Long, _
|
||||
Optional ByVal charset As String = "cp932", _
|
||||
Optional ByVal hasHeader As Boolean = False) As Variant
|
||||
|
||||
' === validate expectedColumnCount ===
|
||||
If expectedColumnCount <= 0 Then
|
||||
Err.Raise 5001, , "expectedColumnCount must be >= 1."
|
||||
End If
|
||||
|
||||
If Dir(filePath) = "" Then
|
||||
Err.Raise 5002, , "File not found: " & filePath
|
||||
End If
|
||||
|
||||
' === read csv file ===
|
||||
Dim stream As Object
|
||||
Set stream = CreateObject("ADODB.Stream")
|
||||
With stream
|
||||
.Type = 2 ' adTypeText
|
||||
.charset = charset
|
||||
.Open
|
||||
.LoadFromFile filePath
|
||||
Dim textContent As String
|
||||
textContent = .ReadText
|
||||
.Close
|
||||
End With
|
||||
|
||||
' === stardand ===
|
||||
textContent = Replace(textContent, vbCrLf, vbLf)
|
||||
textContent = Replace(textContent, vbCr, vbLf)
|
||||
|
||||
' === transfer into collection ===
|
||||
Dim lines As Collection
|
||||
Set lines = ParseCSVLines(textContent)
|
||||
|
||||
' === validate empty ===
|
||||
If lines.Count = 0 Then
|
||||
Err.Raise 5003, , "CSV file is empty."
|
||||
End If
|
||||
|
||||
' === loop the row, validate column count ===
|
||||
Dim i As Long
|
||||
For i = 1 To lines.Count
|
||||
Dim rowArr As Variant
|
||||
rowArr = lines(i)
|
||||
Dim actualCols As Long
|
||||
actualCols = UBound(rowArr) - LBound(rowArr) + 1
|
||||
|
||||
If actualCols <> expectedColumnCount Then
|
||||
Err.Raise 5004, , "Row " & i & ": Expected " & expectedColumnCount & " columns, got " & actualCols & "."
|
||||
End If
|
||||
Next i
|
||||
|
||||
Dim result As Variant
|
||||
ReDim result(1 To lines.Count, 1 To expectedColumnCount)
|
||||
|
||||
For i = 1 To lines.Count
|
||||
rowArr = lines(i)
|
||||
Dim j As Long
|
||||
For j = LBound(rowArr) To UBound(rowArr)
|
||||
result(i, j - LBound(rowArr) + 1) = rowArr(j)
|
||||
Next j
|
||||
Next i
|
||||
|
||||
ReadCSVAs2DArrayStrict = result
|
||||
End Function
|
||||
|
||||
' Helper function: Parse CSV text into collection of string arrays (zero-based per row)
|
||||
Private Function ParseCSVLines(ByVal csvText As String) As Collection
|
||||
Set ParseCSVLines = New Collection
|
||||
Dim length As Long: length = Len(csvText)
|
||||
If length = 0 Then Exit Function
|
||||
|
||||
Dim i As Long: i = 1
|
||||
Dim currentField As String
|
||||
Dim currentRow As Collection: Set currentRow = New Collection
|
||||
Dim inQuotes As Boolean
|
||||
Dim c As String
|
||||
|
||||
Do While i <= length
|
||||
c = Mid$(csvText, i, 1)
|
||||
Select Case c
|
||||
Case """"
|
||||
If inQuotes Then
|
||||
If i < length And Mid$(csvText, i + 1, 1) = """" Then
|
||||
currentField = currentField & """"
|
||||
i = i + 2
|
||||
Else
|
||||
inQuotes = False
|
||||
i = i + 1
|
||||
End If
|
||||
Else
|
||||
inQuotes = True
|
||||
i = i + 1
|
||||
End If
|
||||
Case ","
|
||||
If inQuotes Then
|
||||
currentField = currentField & c
|
||||
i = i + 1
|
||||
Else
|
||||
currentRow.Add currentField
|
||||
currentField = ""
|
||||
i = i + 1
|
||||
End If
|
||||
Case vbLf
|
||||
If inQuotes Then
|
||||
currentField = currentField & c
|
||||
i = i + 1
|
||||
Else
|
||||
currentRow.Add currentField
|
||||
Dim arr() As String
|
||||
If currentRow.Count > 0 Then
|
||||
ReDim arr(0 To currentRow.Count - 1)
|
||||
Dim k As Long
|
||||
For k = 1 To currentRow.Count
|
||||
arr(k - 1) = currentRow(k)
|
||||
Next k
|
||||
End If
|
||||
ParseCSVLines.Add arr
|
||||
Set currentRow = New Collection
|
||||
currentField = ""
|
||||
inQuotes = False
|
||||
i = i + 1
|
||||
End If
|
||||
Case Else
|
||||
currentField = currentField & c
|
||||
i = i + 1
|
||||
End Select
|
||||
Loop
|
||||
|
||||
' Handle last row without trailing newline
|
||||
If currentField <> "" Or currentRow.Count > 0 Then
|
||||
currentRow.Add currentField
|
||||
Dim lastArr() As String
|
||||
If currentRow.Count > 0 Then
|
||||
ReDim lastArr(0 To currentRow.Count - 1)
|
||||
Dim m As Long
|
||||
For m = 1 To currentRow.Count
|
||||
lastArr(m - 1) = currentRow(m)
|
||||
Next m
|
||||
End If
|
||||
ParseCSVLines.Add lastArr
|
||||
End If
|
||||
End Function
|
||||
138
src/module/Write_Common.bas
Normal file
138
src/module/Write_Common.bas
Normal file
@@ -0,0 +1,138 @@
|
||||
Function GetSaveCSVPath(Optional ByVal defaultName As String = "") As String
|
||||
Dim savePath As String
|
||||
savePath = Application.GetSaveAsFilename( _
|
||||
FileFilter:="CSV Files (*.csv), *.csv", _
|
||||
Title:="Save CSV", _
|
||||
InitialFileName:=defaultName)
|
||||
|
||||
If savePath = "False" Or savePath = "" Then
|
||||
GetSaveCSVPath = ""
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
If InStr(1, savePath, ".csv", vbTextCompare) = 0 Then
|
||||
savePath = savePath & ".csv"
|
||||
End If
|
||||
|
||||
GetSaveCSVPath = savePath
|
||||
End Function
|
||||
|
||||
' Writes a 2D array to a CSV file
|
||||
Sub WriteCSVFromArray( _
|
||||
ByVal filePath As String, _
|
||||
ByVal data As Variant, _
|
||||
Optional ByVal Charset As String = "shift_jis", _
|
||||
Optional ByVal alwaysQuote As Boolean = False _
|
||||
)
|
||||
' === Input validation ===
|
||||
If Not IsArray(data) Then
|
||||
Err.Raise 513, , "Input 'data' must be an array."
|
||||
End If
|
||||
|
||||
Dim numDims As Long
|
||||
On Error Resume Next
|
||||
numDims = ArrayDimensions(data)
|
||||
On Error GoTo 0
|
||||
If numDims <> 2 Then
|
||||
Err.Raise 514, , "Input array must be 2-dimensional."
|
||||
End If
|
||||
|
||||
Dim rows As Long, cols As Long
|
||||
rows = UBound(data, 1) - LBound(data, 1) + 1
|
||||
cols = UBound(data, 2) - LBound(data, 2) + 1
|
||||
|
||||
If rows = 0 Or cols = 0 Then Exit Sub ' Empty array, exit early
|
||||
|
||||
' === Build CSV content ===
|
||||
Dim outputLines As Collection
|
||||
Set outputLines = New Collection
|
||||
|
||||
Dim i As Long, j As Long
|
||||
Dim rowStr As String
|
||||
Dim field As String
|
||||
Dim needsQuote As Boolean
|
||||
|
||||
For i = LBound(data, 1) To UBound(data, 1)
|
||||
Dim fields As Variant
|
||||
ReDim fields(1 To cols)
|
||||
|
||||
For j = LBound(data, 2) To UBound(data, 2)
|
||||
' Safely convert variant to string
|
||||
field = SafeToString(data(i, j))
|
||||
|
||||
' Determine if the field needs quoting (per RFC 4180)
|
||||
needsQuote = alwaysQuote Or (InStr(field, """") > 0) Or _
|
||||
(InStr(field, ",") > 0) Or _
|
||||
(InStr(field, vbLf) > 0) Or _
|
||||
(InStr(field, vbCrLf) > 0) Or _
|
||||
(InStr(field, vbCr) > 0) Or _
|
||||
(Left(field, 1) = " " Or Right(field, 1) = " ")
|
||||
|
||||
If needsQuote Then
|
||||
' Escape double quotes: "" represents a single "
|
||||
field = """" & Replace(field, """", """""") & """"
|
||||
End If
|
||||
|
||||
fields(j - LBound(data, 2) + 1) = field
|
||||
Next j
|
||||
|
||||
rowStr = Join(fields, ",")
|
||||
outputLines.Add rowStr
|
||||
Next i
|
||||
|
||||
' Concatenate all lines
|
||||
Dim finalContent As String
|
||||
finalContent = Join(CollectionToArray(outputLines), vbCrLf)
|
||||
|
||||
' === Write to file ===
|
||||
Dim stream As Object
|
||||
Set stream = CreateObject("ADODB.Stream")
|
||||
With stream
|
||||
.Type = 2 ' adTypeText
|
||||
.Charset = Charset
|
||||
.Open
|
||||
.WriteText finalContent, 0 ' adWriteChar
|
||||
.SaveToFile filePath, 2 ' adSaveCreateOverWrite
|
||||
.Close
|
||||
End With
|
||||
End Sub
|
||||
|
||||
' Helper function: safely convert any Variant to a string
|
||||
Private Function SafeToString(ByVal v As Variant) As String
|
||||
On Error Resume Next
|
||||
If IsNull(v) Or IsEmpty(v) Then
|
||||
SafeToString = ""
|
||||
Else
|
||||
SafeToString = CStr(v)
|
||||
End If
|
||||
On Error GoTo 0
|
||||
End Function
|
||||
|
||||
' Helper function: get the number of dimensions of an array (1, 2, ...)
|
||||
Private Function ArrayDimensions(arr As Variant) As Long
|
||||
Dim dimCount As Long
|
||||
On Error GoTo ExitPoint
|
||||
Do
|
||||
dimCount = dimCount + 1
|
||||
Dim tmp As Long
|
||||
tmp = UBound(arr, dimCount)
|
||||
Loop
|
||||
ExitPoint:
|
||||
ArrayDimensions = dimCount - 1
|
||||
End Function
|
||||
|
||||
' Helper function: convert a Collection to a 1D array (for use with Join)
|
||||
Private Function CollectionToArray(col As Collection) As Variant
|
||||
If col.Count = 0 Then
|
||||
CollectionToArray = Array()
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim arr() As String
|
||||
ReDim arr(1 To col.Count)
|
||||
Dim i As Long
|
||||
For i = 1 To col.Count
|
||||
arr(i) = col(i)
|
||||
Next i
|
||||
CollectionToArray = arr
|
||||
End Function
|
||||
226
src/thisWorkbook/Kotsu_master.bas
Normal file
226
src/thisWorkbook/Kotsu_master.bas
Normal file
@@ -0,0 +1,226 @@
|
||||
Sub Z1_ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long)
|
||||
ws.Range(ws.Cells(rowNum, 4), ws.Cells(rowNum, 15)).ClearContents
|
||||
ws.Cells(rowNum, 2).ClearContents
|
||||
End Sub
|
||||
|
||||
Sub Z1_ImportMasterDetailData()
|
||||
Dim filePath As String
|
||||
Dim wsTarget As Worksheet
|
||||
Dim lines As Variant
|
||||
Dim i As Long
|
||||
Dim dataArray As Variant
|
||||
Dim code As String
|
||||
Dim writeRow As Long
|
||||
|
||||
Set wsTarget = Me
|
||||
On Error GoTo ErrorHandler
|
||||
|
||||
' Step 1: Select CSV file
|
||||
filePath = SelectCSVFile()
|
||||
If filePath = "" Then Exit Sub
|
||||
|
||||
' Step 2: Read CSV and return 2D array
|
||||
lines = ReadCSVAs2DArrayStrict(filePath, 7, "utf-8")
|
||||
|
||||
' Step 3: Clear data rows
|
||||
Call ClearDataRows(wsTarget, 7, 3)
|
||||
|
||||
' Step 4: Import data
|
||||
writeRow = 7
|
||||
For i = LBound(lines, 1) To UBound(lines, 1)
|
||||
If Not isRowEmpty Then
|
||||
wsTarget.Cells(writeRow, 3).Value = CleanCSVField(CStr(lines(i, 1)))
|
||||
wsTarget.Cells(writeRow, 4).Value = CleanCSVField(CStr(lines(i, 2)))
|
||||
wsTarget.Cells(writeRow, 5).Value = CleanCSVField(CStr(lines(i, 3)))
|
||||
wsTarget.Cells(writeRow, 6).Value = CleanCSVField(CStr(lines(i, 4)))
|
||||
wsTarget.Cells(writeRow, 7).Value = CleanCSVField(CStr(lines(i, 5)))
|
||||
wsTarget.Cells(writeRow, 8).Value = CleanCSVField(CStr(lines(i, 6)))
|
||||
wsTarget.Cells(writeRow, 9).Value = CleanCSVField(CStr(lines(i, 7)))
|
||||
|
||||
writeRow = writeRow + 1
|
||||
End If
|
||||
Next i
|
||||
|
||||
MsgBox writeRow - 7 & " rows imported.", vbInformation
|
||||
|
||||
Exit Sub
|
||||
|
||||
ErrorHandler:
|
||||
MsgBox "Import fails:" & vbCrLf & Err.Description, vbCritical
|
||||
End Sub
|
||||
|
||||
Sub Z1_ExportMasterDetailData()
|
||||
Dim ws As Worksheet
|
||||
Dim lastDataRow As Long
|
||||
Dim savePath As String
|
||||
Dim r As Long
|
||||
Dim rowCount As Long
|
||||
Dim dataArray() As Variant
|
||||
Dim dataIdx As Long
|
||||
Dim j As Long
|
||||
|
||||
Set ws = ActiveSheet
|
||||
|
||||
lastDataRow = GetLastDataRow(ws, 3)
|
||||
|
||||
If lastDataRow < 7 Then
|
||||
MsgBox "No data rows to output.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
savePath = GetSaveCSVPath()
|
||||
If savePath = "" Then Exit Sub
|
||||
|
||||
' Count valid rows first (C column non-empty from row 7 onward)
|
||||
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 no data, exit
|
||||
If rowCount = 0 Then
|
||||
MsgBox "No data rows to output.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' Initialize 2D array: (1 To rowCount, 1 To 7) for columns C-I (3 to 9)
|
||||
ReDim dataArray(1 To rowCount, 1 To 7)
|
||||
|
||||
' Fill the array
|
||||
dataIdx = 0
|
||||
For r = 7 To lastDataRow
|
||||
If Len(Trim(ws.Cells(r, 3).Value & "")) > 0 Then
|
||||
dataIdx = dataIdx + 1
|
||||
For j = 3 To 9
|
||||
dataArray(dataIdx, j - 2) = ws.Cells(r, j).Value ' C->1, D->2, ..., I->7
|
||||
Next j
|
||||
End If
|
||||
Next r
|
||||
|
||||
' Write using the new array-based CSV writer
|
||||
Call WriteCSVFromArray(savePath, dataArray, "utf-8", True)
|
||||
|
||||
MsgBox "CSV export completed. Total data rows: " & rowCount, vbInformation
|
||||
End Sub
|
||||
|
||||
Sub Z1_validateDetailData(ByVal ws As Worksheet, ByVal rowNum As Long)
|
||||
Dim cValue As String
|
||||
cValue = Trim(ws.Cells(rowNum, 3).Value)
|
||||
|
||||
If cValue = "" Then
|
||||
ws.Cells(rowNum, 2).Value = "C column is required"
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
If Len(cValue) <> 3 Then
|
||||
ws.Cells(rowNum, 2).Value = "C column must be 3 characters"
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim i As Long
|
||||
Dim ch As String
|
||||
For i = 1 To 3
|
||||
ch = Mid(cValue, i, 1)
|
||||
If Not ((ch >= "0" And ch <= "9") Or (ch >= "A" And ch <= "Z") Or (ch >= "a" And ch <= "z")) Then
|
||||
ws.Cells(rowNum, 2).Value = "C column must be alphanumeric"
|
||||
Exit Sub
|
||||
End If
|
||||
Next i
|
||||
|
||||
Dim dValue As String
|
||||
dValue = Trim(ws.Cells(rowNum, 4).Value)
|
||||
If dValue = "" Then
|
||||
ws.Cells(rowNum, 2).Value = "D column is required"
|
||||
Exit Sub
|
||||
End If
|
||||
If Len(dValue) > 80 Then
|
||||
ws.Cells(rowNum, 2).Value = "D column must be within 80 characters"
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim eValue As String
|
||||
eValue = Trim(ws.Cells(rowNum, 5).Value)
|
||||
If eValue = "" Then
|
||||
ws.Cells(rowNum, 2).Value = "E column is required"
|
||||
Exit Sub
|
||||
End If
|
||||
If Len(eValue) > 80 Then
|
||||
ws.Cells(rowNum, 2).Value = "E column must be within 80 characters"
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim fValue As String
|
||||
fValue = Trim(ws.Cells(rowNum, 6).Value)
|
||||
If fValue <> "" And Len(fValue) > 80 Then
|
||||
ws.Cells(rowNum, 2).Value = "F column must be within 80 characters"
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim gValue As String
|
||||
gValue = Trim(ws.Cells(rowNum, 7).Value)
|
||||
If gValue <> "" And Len(gValue) > 80 Then
|
||||
ws.Cells(rowNum, 2).Value = "G column must be within 80 characters"
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim iValue As String
|
||||
iValue = Trim(ws.Cells(rowNum, 9).Value)
|
||||
If iValue <> "" And Len(iValue) > 80 Then
|
||||
ws.Cells(rowNum, 2).Value = "I column must be within 80 characters"
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim hValue As String
|
||||
hValue = Trim(ws.Cells(rowNum, 8).Value)
|
||||
If hValue <> "" Then
|
||||
If Len(hValue) <> 1 Then
|
||||
ws.Cells(rowNum, 2).Value = "H column must be 1 digit"
|
||||
Exit Sub
|
||||
End If
|
||||
If hValue <> "0" And hValue <> "1" Then
|
||||
ws.Cells(rowNum, 2).Value = "H column must be 0 or 1"
|
||||
Exit Sub
|
||||
End If
|
||||
End If
|
||||
|
||||
ws.Cells(rowNum, 2).ClearContents
|
||||
End Sub
|
||||
|
||||
Sub Z1_validateDetailDataButton()
|
||||
Dim ws As Worksheet
|
||||
Dim lastRow As Long
|
||||
Dim r As Long
|
||||
Dim errorCount As Long
|
||||
|
||||
Set ws = ActiveSheet
|
||||
lastRow = GetLastDataRow(ws, 3)
|
||||
|
||||
If lastRow < 7 Then
|
||||
MsgBox "No data found.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
errorCount = 0
|
||||
For r = 7 To lastRow
|
||||
Call Z1_validateDetailData(ws, r)
|
||||
If Trim(ws.Cells(r, 2).Value) <> "" Then
|
||||
errorCount = errorCount + 1
|
||||
End If
|
||||
Next r
|
||||
|
||||
MsgBox "Validation complete. Errors: " & errorCount, vbInformation
|
||||
End Sub
|
||||
|
||||
Sub Z1_SortDataRowsByC()
|
||||
Call SortDataRows(3)
|
||||
End Sub
|
||||
|
||||
Sub Z1_ToggleAutoFilter()
|
||||
Call ToggleAutoFilter(6)
|
||||
End Sub
|
||||
|
||||
Sub Z1_AutoFitColumnWidth()
|
||||
Call AutoFitColumnWidth()
|
||||
End Sub
|
||||
363
src/thisWorkbook/Kukan_detail_master.bas
Normal file
363
src/thisWorkbook/Kukan_detail_master.bas
Normal file
@@ -0,0 +1,363 @@
|
||||
' CSV Header Constants
|
||||
Const CSV_HEADER As String = "利用区間コード,券種,コード,名称,1箇月運賃/販売額,定期額/券１(額)/利用額,定期支給期間/券１(枚)/特別料金,特別料金/券２(額),券２(枚),端数(額),特別料金"
|
||||
|
||||
Private Sub Worksheet_Change(ByVal Target As Range)
|
||||
' === Fill D, E when C column changes ===
|
||||
If Target.Column = 3 And Target.Row >= 7 Then
|
||||
Dim cell As Range
|
||||
For Each cell In Target
|
||||
If Trim(cell.Value) = "" Then
|
||||
Call ClearRowData(Me, cell.Row)
|
||||
Else
|
||||
Call FillFromKukanMaster(Me, cell.Row)
|
||||
End If
|
||||
Next
|
||||
End If
|
||||
End Sub
|
||||
|
||||
Sub FillFromKukanMaster(ByVal ws As Worksheet, ByVal rowNum As Long, Optional ByVal setG As Boolean = True)
|
||||
Dim wsKukan As Worksheet
|
||||
Dim lastRow As Long
|
||||
Dim i As Long
|
||||
Dim code As String
|
||||
|
||||
On Error Resume Next
|
||||
Set wsKukan = ThisWorkbook.Worksheets("M1")
|
||||
If wsKukan Is Nothing Then Exit Sub
|
||||
On Error GoTo 0
|
||||
code = Trim(ws.Cells(rowNum, 3).Value)
|
||||
If code = "" Then Exit Sub
|
||||
lastRow = wsKukan.Cells(wsKukan.Rows.Count, 3).End(xlUp).Row
|
||||
|
||||
For i = 7 To lastRow
|
||||
If Trim(wsKukan.Cells(i, 3).Value) = code Then
|
||||
ws.Cells(rowNum, 4).Value = Trim(wsKukan.Cells(i, 4).Value) & ": " & Trim(wsKukan.Cells(i, 5).Value)
|
||||
ws.Cells(rowNum, 5).Value = Trim(wsKukan.Cells(i, 6).Value)
|
||||
ws.Cells(rowNum, 6).Value = Trim(wsKukan.Cells(i, 7).Value)
|
||||
ws.Cells(rowNum, 7).Value = Trim(wsKukan.Cells(i, 9).Value)
|
||||
ws.Cells(rowNum, 8).Value = Trim(wsKukan.Cells(i, 14).Value)
|
||||
If setG Then
|
||||
ws.Cells(rowNum, 7).Value = "1"
|
||||
End If
|
||||
Exit Sub
|
||||
End If
|
||||
Next
|
||||
|
||||
Call ClearRowData(ws, rowNum)
|
||||
End Sub
|
||||
|
||||
|
||||
Sub ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long)
|
||||
' Clear from D column onwards
|
||||
ws.Range(ws.Cells(rowNum, 4), ws.Cells(rowNum, 15)).ClearContents
|
||||
ws.Cells(rowNum, 6).Validation.Delete
|
||||
ws.Cells(rowNum, 19).ClearContents ' Q column error info
|
||||
End Sub
|
||||
|
||||
Sub ImportMasterDetailData()
|
||||
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 ===
|
||||
Set fileDialog = Application.FileDialog(msoFileDialogFilePicker)
|
||||
With fileDialog
|
||||
.Filters.Clear
|
||||
.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 ===
|
||||
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
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' === Step 3: Collect CSV codes and data ===
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
|
||||
writeRow = writeRow + 1
|
||||
NextLine:
|
||||
Next i
|
||||
|
||||
MsgBox writeRow - 7 & " rows imported.", vbInformation
|
||||
End Sub
|
||||
|
||||
Function CleanCSVField(ByVal field As Variant) As String
|
||||
If IsEmpty(field) Or IsNull(field) Then
|
||||
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)
|
||||
' Check C column not empty
|
||||
If Trim(ws.Cells(rowNum, 3).Value) = "" Then
|
||||
ws.Cells(rowNum, 19).ClearContents
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' Check G, H required and numeric (for composite key)
|
||||
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"
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
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"
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' Check I (K column) required
|
||||
If Trim(ws.Cells(rowNum, 11).Value) = "" Then
|
||||
ws.Cells(rowNum, 19).Value = "I column (K) is required"
|
||||
Exit Sub
|
||||
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
|
||||
End If
|
||||
Next col
|
||||
|
||||
' Check GH composite key duplicate
|
||||
Dim g As String, h As String
|
||||
Dim r As Long
|
||||
Dim lastRow As Long
|
||||
|
||||
g = Trim(ws.Cells(rowNum, 9).Value)
|
||||
h = Trim(ws.Cells(rowNum, 10).Value)
|
||||
|
||||
lastRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
|
||||
|
||||
For r = 7 To lastRow
|
||||
If r <> rowNum And Trim(ws.Cells(r, 3).Value) = Trim(ws.Cells(rowNum, 3).Value) Then
|
||||
If Trim(ws.Cells(r, 9).Value) = g And Trim(ws.Cells(r, 10).Value) = h Then
|
||||
ws.Cells(rowNum, 19).Value = "GH (I,J) combination already exists"
|
||||
Exit Sub
|
||||
End If
|
||||
End If
|
||||
Next r
|
||||
|
||||
' Validation passed
|
||||
ws.Cells(rowNum, 19).ClearContents
|
||||
End Sub
|
||||
|
||||
|
||||
' Button macro (Validate selected row)
|
||||
Sub validateDetailDataButton()
|
||||
Dim ws As Worksheet
|
||||
Dim lastRow As Long
|
||||
Dim r As Long
|
||||
Dim errorCount As Long
|
||||
|
||||
Set ws = ActiveSheet
|
||||
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
|
||||
|
||||
If lastRow < 7 Then
|
||||
MsgBox "No data found.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
errorCount = 0
|
||||
For r = 7 To lastRow
|
||||
Call validateDetailData(ws, r)
|
||||
If Trim(ws.Cells(r, 17).Value) <> "" Then
|
||||
errorCount = errorCount + 1
|
||||
End If
|
||||
Next r
|
||||
|
||||
MsgBox "Validation complete. Errors: " & errorCount & ", ", vbInformation
|
||||
End Sub
|
||||
|
||||
Sub ExportMasterDetailData()
|
||||
Dim ws As Worksheet
|
||||
Set ws = ActiveSheet
|
||||
|
||||
Dim lastDataRow As Long
|
||||
lastDataRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
|
||||
|
||||
If lastDataRow < 7 Then
|
||||
MsgBox "No data rows to output.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim savePath As String
|
||||
savePath = Application.GetSaveAsFilename( _
|
||||
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
|
||||
If Len(Trim(ws.Cells(r, 3).Value & "")) > 0 Then
|
||||
rowCount = rowCount + 1
|
||||
' CSV col1 -> C column
|
||||
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
|
||||
Next r
|
||||
|
||||
' Trim trailing empty lines
|
||||
Do While Right(csvContent, 1) = vbLf
|
||||
csvContent = Left(csvContent, Len(csvContent) - 1)
|
||||
Loop
|
||||
|
||||
' Write file
|
||||
Dim stream As Object
|
||||
Set stream = CreateObject("ADODB.Stream")
|
||||
stream.Type = 2
|
||||
stream.Charset = "shift_jis"
|
||||
stream.Open
|
||||
stream.WriteText csvContent, 1
|
||||
stream.SaveToFile savePath, 2
|
||||
stream.Close
|
||||
|
||||
MsgBox "CSV export completed. Total data rows: " & rowCount, vbInformation
|
||||
End Sub
|
||||
Reference in New Issue
Block a user