添加区間詳細メンテナンス校验宏 validateDetailData
This commit is contained in:
root
485
vba_code_kukan_detail_master.txt
Normal file
485
vba_code_kukan_detail_master.txt
Normal file
@@ -0,0 +1,485 @@
|
||||
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
|
||||
Reference in New Issue
Block a user