485 lines
16 KiB
Plaintext
485 lines
16 KiB
Plaintext
Private Sub Worksheet_Change(ByVal Target As Range)
|
||
' === G列变化时生成F列下拉列表(匹配冒号左边) ===
|
||
If Target.Column = 7 And Target.Row >= 7 Then
|
||
If Target.Count > 1 Then Exit Sub
|
||
Call MakeFDropdownByG(Me, Target.Row)
|
||
End If
|
||
|
||
' === F列变化时提取冒号左边到G列 ===
|
||
If Target.Column = 6 And Target.Row >= 7 Then
|
||
If Target.Count > 1 Then Exit Sub
|
||
If Trim(Target.Value) <> "" Then
|
||
Dim fValue As String
|
||
fValue = Trim(Target.Value)
|
||
If InStr(fValue, ":") > 0 Then
|
||
Target.Offset(0, 1).Value = Split(fValue, ":")(0)
|
||
' Don't trigger MakeFDropdownByG again - it's already set
|
||
End If
|
||
End If
|
||
End If
|
||
|
||
' === C列变化时填充D、E ===
|
||
If Target.Column = 3 And Target.Row >= 7 Then
|
||
If Target.Count > 1 Then
|
||
' Handle multiple cells
|
||
Dim cell As Range
|
||
For Each cell In Target
|
||
If cell.Column = 3 And cell.Row >= 7 Then
|
||
If Trim(cell.Value) = "" Then
|
||
Call ClearRowData(Me, cell.Row)
|
||
Else
|
||
Call FillFromKukanMaster(Me, cell.Row)
|
||
End If
|
||
End If
|
||
Next cell
|
||
Exit Sub
|
||
End If
|
||
|
||
If Trim(Target.Value) = "" Then
|
||
Call ClearRowData(Me, Target.Row)
|
||
Else
|
||
Call FillFromKukanMaster(Me, Target.Row)
|
||
End If
|
||
End If
|
||
End Sub
|
||
|
||
|
||
|
||
Sub MakeFDropdownByG(ByVal ws As Worksheet, ByVal rowNum As Long)
|
||
Dim wsKotsu As Worksheet
|
||
Dim lastRowKotsu As Long
|
||
Dim k As Long
|
||
Dim kotsuList As String
|
||
Dim kotsuA As String
|
||
Dim kotsuB As String
|
||
Dim gValue As String
|
||
Dim fVal As String
|
||
Dim targetCellF As Range
|
||
|
||
gValue = Trim(ws.Cells(rowNum, 7).Value)
|
||
fVal = Trim(ws.Cells(rowNum, 6).Value)
|
||
|
||
' Skip if F already has matching value (prevent loop)
|
||
If fVal <> "" And InStr(fVal, ":") > 0 Then
|
||
If Split(fVal, ":")(0) = gValue Then
|
||
Exit Sub
|
||
End If
|
||
End If
|
||
|
||
On Error Resume Next
|
||
Set wsKotsu = ThisWorkbook.Worksheets("交通機関マスタ")
|
||
On Error GoTo 0
|
||
|
||
If wsKotsu Is Nothing Then Exit Sub
|
||
If gValue = "" Then Exit Sub
|
||
|
||
lastRowKotsu = wsKotsu.Cells(wsKotsu.Rows.Count, "A").End(xlUp).Row
|
||
|
||
kotsuList = ""
|
||
For k = 4 To lastRowKotsu
|
||
kotsuA = Trim(wsKotsu.Cells(k, 1).Value)
|
||
kotsuB = Trim(wsKotsu.Cells(k, 2).Value)
|
||
If kotsuA <> "" Then
|
||
If kotsuList <> "" Then kotsuList = kotsuList & ","
|
||
kotsuList = kotsuList & kotsuA & ":" & kotsuB
|
||
End If
|
||
Next k
|
||
|
||
Set targetCellF = ws.Cells(rowNum, 6)
|
||
On Error Resume Next
|
||
targetCellF.ClearContents
|
||
targetCellF.Validation.Delete
|
||
On Error GoTo 0
|
||
|
||
If kotsuList <> "" Then
|
||
On Error Resume Next
|
||
targetCellF.Validation.Add Type:=xlValidateList, Formula1:=kotsuList
|
||
targetCellF.Validation.IgnoreBlank = True
|
||
targetCellF.Validation.ShowDropDownWhenSelected = True
|
||
' Auto select the first matching one
|
||
For k = 4 To lastRowKotsu
|
||
If Trim(wsKotsu.Cells(k, 1).Value) = gValue Then
|
||
targetCellF.Value = gValue & ":" & Trim(wsKotsu.Cells(k, 2).Value)
|
||
Exit For
|
||
End If
|
||
Next k
|
||
End If
|
||
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, vbCrLf)
|
||
|
||
If UBound(lines) < 1 Then
|
||
MsgBox "CSVにデータがありません。", vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
' === Step 3: Collect CSV codes and data (include all columns including コード and 券種) ===
|
||
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 "有効なコードが見つかりません。", 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列
|
||
code = CleanCSVField(CStr(dataArray(0)))
|
||
wsTarget.Cells(writeRow, 3).Value = code
|
||
|
||
' CSV col 2-11 -> G-P列
|
||
If UBound(dataArray) >= 1 Then wsTarget.Cells(writeRow, 7).Value = CleanCSVField(CStr(dataArray(1)))
|
||
If UBound(dataArray) >= 2 Then wsTarget.Cells(writeRow, 8).Value = CleanCSVField(CStr(dataArray(2)))
|
||
If UBound(dataArray) >= 3 Then wsTarget.Cells(writeRow, 9).Value = CleanCSVField(CStr(dataArray(3)))
|
||
If UBound(dataArray) >= 4 Then wsTarget.Cells(writeRow, 10).Value = CleanCSVField(CStr(dataArray(4)))
|
||
If UBound(dataArray) >= 5 Then wsTarget.Cells(writeRow, 11).Value = CleanCSVField(CStr(dataArray(5)))
|
||
If UBound(dataArray) >= 6 Then wsTarget.Cells(writeRow, 12).Value = CleanCSVField(CStr(dataArray(6)))
|
||
If UBound(dataArray) >= 7 Then wsTarget.Cells(writeRow, 13).Value = CleanCSVField(CStr(dataArray(7)))
|
||
If UBound(dataArray) >= 8 Then wsTarget.Cells(writeRow, 14).Value = CleanCSVField(CStr(dataArray(8)))
|
||
If UBound(dataArray) >= 9 Then wsTarget.Cells(writeRow, 15).Value = CleanCSVField(CStr(dataArray(9)))
|
||
If UBound(dataArray) >= 10 Then wsTarget.Cells(writeRow, 16).Value = CleanCSVField(CStr(dataArray(10)))
|
||
|
||
' Auto-fill D, E columns from 区間メンテナンス
|
||
Call FillFromKukanMaster(wsTarget, writeRow, False)
|
||
|
||
' G列已有值 → 触发F下拉列表
|
||
If Trim(wsTarget.Cells(writeRow, 7).Value) <> "" Then
|
||
Call MakeFDropdownByG(wsTarget, writeRow)
|
||
End If
|
||
|
||
writeRow = writeRow + 1
|
||
NextLine:
|
||
Next i
|
||
|
||
MsgBox writeRow - 7 & " 行を取り込みました。", 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 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
|
||
Dim deValue As String
|
||
Dim fgValue As String
|
||
|
||
On Error Resume Next
|
||
Set wsKukan = ThisWorkbook.Worksheets("区間メンテナンス")
|
||
|
||
If wsKukan Is Nothing Then Exit Sub
|
||
|
||
code = Trim(ws.Cells(rowNum, 3).Value)
|
||
If code = "" Then Exit Sub
|
||
|
||
lastRow = wsKukan.Cells(wsKukan.Rows.Count, "C").End(xlUp).Row
|
||
|
||
Dim found As Boolean
|
||
found = False
|
||
|
||
For i = 7 To lastRow
|
||
If Trim(wsKukan.Cells(i, 3).Value) = code Then
|
||
deValue = Trim(wsKukan.Cells(i, 4).Value) & ": " & Trim(wsKukan.Cells(i, 5).Value)
|
||
ws.Cells(rowNum, 4).Value = deValue
|
||
|
||
fgValue = Trim(wsKukan.Cells(i, 6).Value) & "~" & Trim(wsKukan.Cells(i, 7).Value)
|
||
ws.Cells(rowNum, 5).Value = fgValue
|
||
|
||
If setG Then
|
||
ws.Cells(rowNum, 7).Value = "1"
|
||
Call MakeFDropdownByG(ws, rowNum)
|
||
End If
|
||
|
||
found = True
|
||
Exit For
|
||
End If
|
||
Next
|
||
|
||
If Not found Then
|
||
Call ClearRowData(ws, rowNum)
|
||
Exit Sub
|
||
End If
|
||
|
||
|
||
|
||
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, 17).ClearContents ' Q列错误信息
|
||
End Sub
|
||
|
||
Sub validateDetailData(ByVal ws As Worksheet, ByVal rowNum As Long, Optional ByVal isImport As Boolean = False)
|
||
' 关闭屏幕刷新和事件提升性能
|
||
Application.ScreenUpdating = False
|
||
Application.Calculation = xlCalculationManual
|
||
|
||
Dim cValue As String
|
||
Dim jValue As String
|
||
Dim kValue As String
|
||
Dim lValue As String
|
||
Dim mValue As String
|
||
Dim nValue As String
|
||
Dim oValue As String
|
||
Dim pValue As String
|
||
Dim gValue As String
|
||
Dim hValue As String
|
||
Dim iValue As String
|
||
Dim i As Long
|
||
Dim lastRow As Long
|
||
Dim errorMsg As String
|
||
|
||
cValue = Trim(ws.Cells(rowNum, 3).Value)
|
||
If cValue = "" Then
|
||
ws.Cells(rowNum, 17).Value = ""
|
||
Exit Sub
|
||
End If
|
||
|
||
' === J列和K列必须为数字（不能为空） ===
|
||
jValue = Trim(ws.Cells(rowNum, 10).Value)
|
||
kValue = Trim(ws.Cells(rowNum, 11).Value)
|
||
|
||
If jValue = "" Then
|
||
errorMsg = "J列は必須項目です。"
|
||
ws.Cells(rowNum, 17).Value = errorMsg
|
||
Exit Sub
|
||
End If
|
||
|
||
If Not IsNumeric(jValue) Then
|
||
errorMsg = "J列には数値を入力してください。"
|
||
ws.Cells(rowNum, 17).Value = errorMsg
|
||
Exit Sub
|
||
End If
|
||
|
||
If kValue = "" Then
|
||
errorMsg = "K列は必須項目です。"
|
||
ws.Cells(rowNum, 17).Value = errorMsg
|
||
Exit Sub
|
||
End If
|
||
|
||
If Not IsNumeric(kValue) Then
|
||
errorMsg = "K列には数値を入力してください。"
|
||
ws.Cells(rowNum, 17).Value = errorMsg
|
||
Exit Sub
|
||
End If
|
||
|
||
' === L、M、N、O、P列如果输入必须为数字 ===
|
||
lValue = Trim(ws.Cells(rowNum, 12).Value)
|
||
mValue = Trim(ws.Cells(rowNum, 13).Value)
|
||
nValue = Trim(ws.Cells(rowNum, 14).Value)
|
||
oValue = Trim(ws.Cells(rowNum, 15).Value)
|
||
pValue = Trim(ws.Cells(rowNum, 16).Value)
|
||
|
||
If lValue <> "" And Not IsNumeric(lValue) Then
|
||
errorMsg = "L列には数値を入力してください。"
|
||
ws.Cells(rowNum, 17).Value = errorMsg
|
||
Exit Sub
|
||
End If
|
||
|
||
If mValue <> "" And Not IsNumeric(mValue) Then
|
||
errorMsg = "M列には数値を入力してください。"
|
||
ws.Cells(rowNum, 17).Value = errorMsg
|
||
Exit Sub
|
||
End If
|
||
|
||
If nValue <> "" And Not IsNumeric(nValue) Then
|
||
errorMsg = "N列には数値を入力してください。"
|
||
ws.Cells(rowNum, 17).Value = errorMsg
|
||
Exit Sub
|
||
End If
|
||
|
||
If oValue <> "" And Not IsNumeric(oValue) Then
|
||
errorMsg = "O列には数値を入力してください。"
|
||
ws.Cells(rowNum, 17).Value = errorMsg
|
||
Exit Sub
|
||
End If
|
||
|
||
If pValue <> "" And Not IsNumeric(pValue) Then
|
||
errorMsg = "P列には数値を入力してください。"
|
||
ws.Cells(rowNum, 17).Value = errorMsg
|
||
Exit Sub
|
||
End If
|
||
|
||
' === G、H、I列联合主键检查重复 ===
|
||
gValue = Trim(ws.Cells(rowNum, 7).Value)
|
||
hValue = Trim(ws.Cells(rowNum, 8).Value)
|
||
iValue = Trim(ws.Cells(rowNum, 9).Value)
|
||
|
||
If gValue <> "" And hValue <> "" And iValue <> "" Then
|
||
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
|
||
|
||
For i = 7 To lastRow
|
||
If i <> rowNum Then
|
||
If Trim(ws.Cells(i, 3).Value) = cValue Then
|
||
If Trim(ws.Cells(i, 7).Value) = gValue And _
|
||
Trim(ws.Cells(i, 8).Value) = hValue And _
|
||
Trim(ws.Cells(i, 9).Value) = iValue Then
|
||
errorMsg = "GHI列の組が既に存在します。"
|
||
ws.Cells(rowNum, 17).Value = errorMsg
|
||
Exit Sub
|
||
End If
|
||
End If
|
||
End If
|
||
Next i
|
||
End If
|
||
|
||
' 验证通过，清除Q列错误信息
|
||
ws.Cells(rowNum, 17).Value = ""
|
||
|
||
' 恢复设置
|
||
Application.ScreenUpdating = True
|
||
Application.Calculation = xlCalculationAutomatic
|
||
|
||
End Sub
|
||
|
||
' 按钮调用的宏（验证当前选中行）
|
||
Sub validateDetailDataButton()
|
||
Dim rowNum As Long
|
||
rowNum = ActiveCell.Row
|
||
|
||
If rowNum < 7 Then
|
||
MsgBox "データ行を選択してください。", vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
Call validateDetailData(ActiveSheet, rowNum)
|
||
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 "出力するデータ行がありません。", vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
Dim savePath As String
|
||
savePath = Application.GetSaveAsFilename( _
|
||
FileFilter:="CSV Files (*.csv), *.csv", _
|
||
Title:="CSV保存")
|
||
|
||
If savePath = "False" Then Exit Sub
|
||
If InStr(1, savePath, ".csv", vbTextCompare) = 0 Then
|
||
savePath = savePath & ".csv"
|
||
End If
|
||
|
||
' Header: 利用区間コード,券種,コード,名称,1箇月運賃/販売額,定期額/券１(額)/利用額,定期支給期間/券１(枚)/特別料金,特別料金/券２(額),券２(枚),端数(額),特別料金
|
||
Dim headerList As Variant
|
||
headerList = Array("利用区間コード", "券種", "コード", "名称", "1箇月運賃/販売額", "定期額/券１(額)/利用額", "定期支給期間/券１(枚)/特別料金", "特別料金/券２(額)", "券２(枚)", "端数(額)", "特別料金")
|
||
|
||
' Build CSV
|
||
Dim csvContent As String
|
||
Dim j As Long
|
||
|
||
For j = 0 To UBound(headerList)
|
||
If j > 0 Then csvContent = csvContent & ","
|
||
csvContent = csvContent & headerList(j)
|
||
Next j
|
||
csvContent = csvContent & vbCrLf
|
||
|
||
' 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 Trim(ws.Cells(r, 3).Value) <> "" Then
|
||
' CSV col1 -> C列
|
||
csvContent = csvContent & CleanCSVField(ws.Cells(r, 3).Value)
|
||
' CSV col2-11 -> G-P列
|
||
For j = 7 To 16
|
||
csvContent = csvContent & "," & CleanCSVField(ws.Cells(r, j).Value)
|
||
Next j
|
||
csvContent = csvContent & vbCrLf
|
||
End If
|
||
Next r
|
||
|
||
' 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出力が完了しました。", vbInformation
|
||
End Sub |