refactor
This commit is contained in:
updsv7
292
src/sh/juk/sheet/J1.cls
Normal file
292
src/sh/juk/sheet/J1.cls
Normal file
@@ -0,0 +1,292 @@
|
||||
' ============================================================
|
||||
' JUK CSV Item Definition Generator
|
||||
'
|
||||
' Description:
|
||||
' Excel の CSV 項目定義シートから sh_csv_item_definition テーブル用の
|
||||
' DML INSERT 文を生成する
|
||||
'
|
||||
' Usage:
|
||||
' 1. 「CSV項目定義」シートを開く
|
||||
' 2. VBAエディタで J1.cls をインポート
|
||||
' 3. GenerateJukCsvItemDefinition マクロを実行
|
||||
' 4. 同じフォルダに juk_csv_item_definition.sql が生成される
|
||||
'
|
||||
' Column Mapping:
|
||||
' C - 順序号 (item_seq)
|
||||
' D - 項目名 (item_title)
|
||||
' P - データ型 (data_type)
|
||||
' V - PK (is_duplicate_check_key)
|
||||
' W - 必须入力 (nullable) - 反転
|
||||
' X - 定義チェック (enable_format_check)
|
||||
' Y - 存在チェック (enable_exist_check)
|
||||
' Z - 関連チェック (enable_relation_check)
|
||||
' AA -許可値 (allowed_values)
|
||||
' BI - JsonIgnore (json_ignore)
|
||||
'
|
||||
' Output Sample:
|
||||
' INSERT INTO sh_csv_item_definition (CODE, ITEM_SEQ, ITEM_TITLE, ITEM_NAME, IS_DUPLICATE_CHECK_KEY, DATA_TYPE, PRECISION, SCALE, NULLABLE, ENABLE_FORMAT_CHECK, FORMAT_REGEX, ENABLE_EXIST_CHECK, ALLOWED_VALUES, MASTER_SYBT, ENABLE_RELATION_CHECK, JSON_IGNORE, CMNUSER) VALUES ('JUK', 1, '職員番号', '', TRUE, 'CHAR', 8, NULL, FALSE, FALSE, '', TRUE, NULL, '', FALSE, FALSE, 'updsv7');
|
||||
' ============================================================
|
||||
|
||||
Option Explicit
|
||||
|
||||
' --- 設定 ---
|
||||
Private Const TARGET_SHEET_NAME As String = "CSV項目定義"
|
||||
Private Const OUTPUT_FILE_NAME As String = "juk_csv_item_definition.sql"
|
||||
Private Const DATA_START_ROW As Long = 9
|
||||
Private Const CODE_PREFIX As String = "JUK"
|
||||
Private Const DEFAULT_CMNUSER As String = "updsv7"
|
||||
|
||||
' --- カラム位置 (Excel 列番号) ---
|
||||
Private Const COL_ITEM_SEQ As Long = 3
|
||||
Private Const COL_ITEM_TITLE As Long = 4
|
||||
Private Const COL_DATA_TYPE As Long = 16
|
||||
Private Const COL_PK As Long = 22
|
||||
Private Const COL_REQUIRED As Long = 23
|
||||
Private Const COL_FORMAT_CHECK As Long = 24
|
||||
Private Const COL_EXIST_CHECK As Long = 25
|
||||
Private Const COL_RELATION_CHECK As Long = 26
|
||||
Private Const COL_ALLOWED_VALUES As Long = 27
|
||||
Private Const COL_JSON_IGNORE As Long = 61
|
||||
|
||||
' --- フィールド名 (DDLフィールド名→大写) ---
|
||||
Private Const CODE = "CODE"
|
||||
Private Const ITEM_SEQ = "ITEM_SEQ"
|
||||
Private Const ITEM_TITLE = "ITEM_TITLE"
|
||||
Private Const ITEM_NAME = "ITEM_NAME"
|
||||
Private Const IS_DUPLICATE_CHECK_KEY = "IS_DUPLICATE_CHECK_KEY"
|
||||
Private Const DATA_TYPE = "DATA_TYPE"
|
||||
Private Const PRECISION = "PRECISION"
|
||||
Private Const SCALE = "SCALE"
|
||||
Private Const NULLABLE = "NULLABLE"
|
||||
Private Const ENABLE_FORMAT_CHECK = "ENABLE_FORMAT_CHECK"
|
||||
Private Const FORMAT_REGEX = "FORMAT_REGEX"
|
||||
Private Const ENABLE_EXIST_CHECK = "ENABLE_EXIST_CHECK"
|
||||
Private Const ALLOWED_VALUES = "ALLOWED_VALUES"
|
||||
Private Const MASTER_SYBT = "MASTER_SYBT"
|
||||
Private Const ENABLE_RELATION_CHECK = "ENABLE_RELATION_CHECK"
|
||||
Private Const JSON_IGNORE = "JSON_IGNORE"
|
||||
Private Const CMNUSER = "CMNUSER"
|
||||
|
||||
|
||||
' ============================================================
|
||||
' Main: GenerateJukCsvItemDefinition
|
||||
' ============================================================
|
||||
Public Sub GenerateJukCsvItemDefinition()
|
||||
Dim ws As Worksheet
|
||||
Dim outputPath As String
|
||||
Dim sqlLines As String
|
||||
Dim lastRow As Long
|
||||
Dim i As Long
|
||||
Dim sql As String
|
||||
|
||||
On Error Resume Next
|
||||
Set ws = ThisWorkbook.Worksheets(TARGET_SHEET_NAME)
|
||||
On Error GoTo 0
|
||||
|
||||
If ws Is Nothing Then
|
||||
MsgBox "シート [" & TARGET_SHEET_NAME & "] が見つかりません。", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
lastRow = ws.Cells(ws.Rows.Count, COL_ITEM_TITLE).End(xlUp).Row
|
||||
|
||||
If lastRow < DATA_START_ROW Then
|
||||
MsgBox "データが見つかりません。", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
sqlLines = ""
|
||||
|
||||
For i = DATA_START_ROW To lastRow
|
||||
sql = GenerateSqlForRow(ws, i)
|
||||
If sql <> "" Then
|
||||
sqlLines = sqlLines & sql & vbCrLf
|
||||
End If
|
||||
Next i
|
||||
|
||||
If sqlLines = "" Then
|
||||
MsgBox "出力するデータがありませんでした。", vbInformation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
outputPath = ThisWorkbook.Path & "\" & OUTPUT_FILE_NAME
|
||||
|
||||
Call WriteTextFile(outputPath, FormatSql(sqlLines))
|
||||
|
||||
MsgBox "SQLファイルを生成しました:" & vbCrLf & outputPath, vbInformation
|
||||
|
||||
End Sub
|
||||
|
||||
|
||||
' ============================================================
|
||||
' Generate SQL for a single row
|
||||
' IDE表示用: 只需要对value做注释
|
||||
' ============================================================
|
||||
Private Function GenerateSqlForRow(ws As Worksheet, rowNum As Long) As String
|
||||
Dim itemTitle As String
|
||||
Dim itemSeq As Long
|
||||
Dim sqlParts As Variant
|
||||
|
||||
itemTitle = GetCellValue(ws, rowNum, COL_ITEM_TITLE)
|
||||
If itemTitle = "" Then
|
||||
GenerateSqlForRow = ""
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
itemSeq = CLng(GetCellValue(ws, rowNum, COL_ITEM_SEQ))
|
||||
|
||||
sqlParts = Array( _
|
||||
"INSERT INTO sh_csv_item_definition (", _ ' INSERT INTO
|
||||
CODE & ",", _ ' code
|
||||
ITEM_SEQ & ",", _ ' item_seq
|
||||
ITEM_TITLE & ",", _ ' item_title
|
||||
ITEM_NAME & ",", _ ' item_name
|
||||
IS_DUPLICATE_CHECK_KEY & ",", _ ' is_duplicate_check_key
|
||||
DATA_TYPE & ",", _ ' data_type
|
||||
PRECISION & ",", _ ' precision
|
||||
SCALE & ",", _ ' scale
|
||||
NULLABLE & ",", _ ' nullable
|
||||
ENABLE_FORMAT_CHECK & ",", _ ' enable_format_check
|
||||
FORMAT_REGEX & ",", _ ' format_regex
|
||||
ENABLE_EXIST_CHECK & ",", _ ' enable_exist_check
|
||||
ALLOWED_VALUES & ",", _ ' allowed_values
|
||||
MASTER_SYBT & ",", _ ' master_sybt
|
||||
ENABLE_RELATION_CHECK & ",", _ ' enable_relation_check
|
||||
JSON_IGNORE & ",", _ ' json_ignore
|
||||
CMNUSER & ")", _ ' cmnuser
|
||||
") VALUES (", _ ' VALUES
|
||||
GetCode(), _ ' code
|
||||
GetItemSeq(itemSeq), _ ' item_seq
|
||||
SqlString(itemTitle), _ ' item_title
|
||||
GetIsChecked(ws, rowNum, COL_PK), _ ' is_duplicate_check_key
|
||||
SqlString(GetCellValue(ws, rowNum, COL_DATA_TYPE)), _ ' data_type
|
||||
GetNull(), _ ' precision
|
||||
GetNull(), _ ' scale
|
||||
Not GetIsChecked(ws, rowNum, COL_REQUIRED), _ ' nullable
|
||||
GetIsChecked(ws, rowNum, COL_FORMAT_CHECK), _ ' enable_format_check
|
||||
GetEmptyStr(), _ ' format_regex
|
||||
GetIsChecked(ws, rowNum, COL_EXIST_CHECK), _ ' enable_exist_check
|
||||
SqlArrayOrNull(GetCellValue(ws, rowNum, COL_ALLOWED_VALUES)), _ ' allowed_values
|
||||
GetEmptyStr(), _ ' master_sybt
|
||||
GetIsChecked(ws, rowNum, COL_RELATION_CHECK), _ ' enable_relation_check
|
||||
GetIsChecked(ws, rowNum, COL_JSON_IGNORE, True), _ ' json_ignore
|
||||
GetCmnuser()) ' cmnuser
|
||||
|
||||
GenerateSqlForRow = Join(sqlParts, "")
|
||||
|
||||
End Function
|
||||
|
||||
|
||||
' ============================================================
|
||||
' Helper: Get code value
|
||||
' ============================================================
|
||||
Private Function GetCode() As String
|
||||
GetCode = "'" & CODE_PREFIX & "', "
|
||||
End Function
|
||||
|
||||
|
||||
' ============================================================
|
||||
' Helper: Get item_seq value
|
||||
' ============================================================
|
||||
Private Function GetItemSeq(seq As Long) As String
|
||||
GetItemSeq = seq & ", "
|
||||
End Function
|
||||
|
||||
|
||||
' ============================================================
|
||||
' Helper: Get cmnuser value
|
||||
' ============================================================
|
||||
Private Function GetCmnuser() As String
|
||||
GetCmnuser = "'" & DEFAULT_CMNUSER & "'"
|
||||
End Function
|
||||
|
||||
|
||||
' ============================================================
|
||||
' Helper: Get NULL value
|
||||
' ============================================================
|
||||
Private Function GetNull() As String
|
||||
GetNull = "NULL, "
|
||||
End Function
|
||||
|
||||
|
||||
' ============================================================
|
||||
' Helper: Get empty string value
|
||||
' ============================================================
|
||||
Private Function GetEmptyStr() As String
|
||||
GetEmptyStr = "'', "
|
||||
End Function
|
||||
|
||||
|
||||
' ============================================================
|
||||
' Format: 去掉IDE的换行和缩进，输出1行
|
||||
' ============================================================
|
||||
Private Function FormatSql(sql As String) As String
|
||||
Dim lines As Variant
|
||||
Dim i As Long
|
||||
Dim result As String
|
||||
|
||||
lines = Split(sql, vbCrLf)
|
||||
result = ""
|
||||
|
||||
For i = LBound(lines) To UBound(lines)
|
||||
If Trim(lines(i)) <> "" Then
|
||||
result = result & Trim(lines(i))
|
||||
End If
|
||||
Next i
|
||||
|
||||
FormatSql = result
|
||||
End Function
|
||||
|
||||
|
||||
' ============================================================
|
||||
' Helper: Get cell value as string (trimmed)
|
||||
' ============================================================
|
||||
Private Function GetCellValue(ws As Worksheet, rowNum As Long, colNum As Long) As String
|
||||
GetCellValue = Trim(CStr(ws.Cells(rowNum, colNum).Value))
|
||||
End Function
|
||||
|
||||
|
||||
' ============================================================
|
||||
' Helper: Check if cell contains "○"
|
||||
' ============================================================
|
||||
|
||||
|
||||
' ============================================================
|
||||
' Helper: Boolean to SQL string
|
||||
' ============================================================
|
||||
|
||||
|
||||
' ============================================================
|
||||
' Helper: String to SQL (quoted and escaped)
|
||||
' ============================================================
|
||||
Private Function SqlString(s As String) As String
|
||||
If s = "" Then
|
||||
SqlString = "NULL, "
|
||||
Else
|
||||
SqlString = "'" & Replace(s, "'", "''") & "', "
|
||||
End If
|
||||
End Function
|
||||
|
||||
|
||||
' ============================================================
|
||||
' Helper: Array string to SQL or NULL
|
||||
' ============================================================
|
||||
Private Function SqlArrayOrNull(s As String) As String
|
||||
If s = "" Then
|
||||
SqlArrayOrNull = "NULL, "
|
||||
Else
|
||||
SqlArrayOrNull = "'{" & s & "}', "
|
||||
End If
|
||||
End Function
|
||||
|
||||
|
||||
' ============================================================
|
||||
' Helper: Write text file
|
||||
' ============================================================
|
||||
Private Sub WriteTextFile(filePath As String, content As String)
|
||||
Dim fileNum As Long
|
||||
fileNum = FreeFile
|
||||
Open filePath For Output As #fileNum
|
||||
Print #fileNum, content;
|
||||
Close #fileNum
|
||||
End Sub
|
||||
199
src/sh/tuk/init_module/Import_modules.bas
Normal file
199
src/sh/tuk/init_module/Import_modules.bas
Normal file
@@ -0,0 +1,199 @@
|
||||
Option Explicit
|
||||
|
||||
' Main entry: Validate all files and targets first. Import only if everything is OK.
|
||||
Sub ImportModulesAndSheets_Safe()
|
||||
Dim fso As Object
|
||||
Set fso = CreateObject("Scripting.FileSystemObject")
|
||||
|
||||
Const PROJECT_PATH As String = "D:\Project\upds7\vba\"
|
||||
Const MODULE_PATH As String = PROJECT_PATH & "src\module"
|
||||
Const SHEET_PATH As String = PROJECT_PATH & "src\sheet"
|
||||
|
||||
' --- Phase 1: Validation ---
|
||||
Debug.Print "[LOG] Starting validation phase..."
|
||||
Dim validationErrors As String
|
||||
validationErrors = ValidateAllFilesAndTargets(MODULE_PATH, SHEET_PATH)
|
||||
|
||||
If validationErrors <> "" Then
|
||||
MsgBox "Validation failed. Import aborted:" & vbCrLf & vbCrLf & validationErrors, vbCritical
|
||||
Debug.Print "[LOG] Validation failed. Aborting import."
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' --- Phase 2: Perform import ---
|
||||
On Error GoTo ImportError
|
||||
Application.ScreenUpdating = False
|
||||
|
||||
Debug.Print "[LOG] Validation passed. Starting import phase..."
|
||||
ImportStandardModules MODULE_PATH
|
||||
ImportSheetCLSFiles SHEET_PATH
|
||||
|
||||
Application.ScreenUpdating = True
|
||||
MsgBox "All .bas and .cls files imported successfully!", vbInformation
|
||||
Debug.Print "[LOG] Import completed successfully."
|
||||
Exit Sub
|
||||
|
||||
ImportError:
|
||||
Application.ScreenUpdating = True
|
||||
MsgBox "Error during import: " & Err.Description, vbCritical
|
||||
Debug.Print "[ERROR] Import error (" & Err.Number & "): " & Err.Description
|
||||
End Sub
|
||||
|
||||
' Validate existence of folders, files, and target components
|
||||
Private Function ValidateAllFilesAndTargets(modulePath As String, sheetPath As String) As String
|
||||
Dim fso As Object
|
||||
Set fso = CreateObject("Scripting.FileSystemObject")
|
||||
|
||||
Dim msg As String
|
||||
|
||||
' Check module folder
|
||||
Debug.Print "[LOG] Validating module folder: " & modulePath
|
||||
If Not fso.FolderExists(modulePath) Then
|
||||
msg = msg & "• Module folder not found: " & modulePath & vbCrLf
|
||||
Debug.Print "[WARNING] Module folder not found."
|
||||
Else
|
||||
Dim file As Object
|
||||
For Each file In fso.GetFolder(modulePath).Files
|
||||
If LCase(fso.GetExtensionName(file.Name)) = "bas" Then
|
||||
Dim modName As String
|
||||
modName = fso.GetBaseName(file.Name)
|
||||
Debug.Print "[LOG] Found .bas file: " & file.Name & " (CodeName: " & modName & ")"
|
||||
If Not IsValidVBComponentName(modName) Then
|
||||
msg = msg & "• Invalid module name (.bas): '" & modName & "'" & vbCrLf
|
||||
Debug.Print "[WARNING] Invalid module name: " & modName
|
||||
End If
|
||||
End If
|
||||
Next file
|
||||
End If
|
||||
|
||||
' Check sheet folder
|
||||
Debug.Print "[LOG] Validating sheet folder: " & sheetPath
|
||||
If Not fso.FolderExists(sheetPath) Then
|
||||
msg = msg & "• Sheet macro folder not found: " & sheetPath & vbCrLf
|
||||
Debug.Print "[WARNING] Sheet folder not found."
|
||||
Else
|
||||
For Each file In fso.GetFolder(sheetPath).Files
|
||||
If LCase(fso.GetExtensionName(file.Name)) = "cls" Then
|
||||
Dim sheetCodeName As String
|
||||
sheetCodeName = fso.GetBaseName(file.Name)
|
||||
Debug.Print "[LOG] Found .cls file: " & file.Name & " (Target CodeName: " & sheetCodeName & ")"
|
||||
|
||||
Dim cmp As Object
|
||||
On Error Resume Next
|
||||
Set cmp = ThisWorkbook.VBProject.VBComponents(sheetCodeName)
|
||||
On Error GoTo 0
|
||||
|
||||
If cmp Is Nothing Then
|
||||
msg = msg & "• No worksheet with CodeName: '" & sheetCodeName & "'" & vbCrLf
|
||||
Debug.Print "[WARNING] Worksheet with CodeName '" & sheetCodeName & "' not found."
|
||||
ElseIf cmp.Type <> 100 Then ' 100 = xlWorksheet
|
||||
msg = msg & "• Name exists but is not a worksheet: '" & sheetCodeName & "'" & vbCrLf
|
||||
Debug.Print "[WARNING] Component '" & sheetCodeName & "' exists but is not a worksheet."
|
||||
End If
|
||||
End If
|
||||
Next file
|
||||
End If
|
||||
|
||||
ValidateAllFilesAndTargets = msg
|
||||
End Function
|
||||
|
||||
' Check if name is a valid VBA component name (ASCII only, starts with letter)
|
||||
Private Function IsValidVBComponentName(name As String) As Boolean
|
||||
If name = "" Then Exit Function
|
||||
If Not (name Like "[A-Za-z]*") Then Exit Function
|
||||
Dim i As Long
|
||||
For i = 1 To Len(name)
|
||||
Dim c As String
|
||||
c = Mid(name, i, 1)
|
||||
If Not (c Like "[A-Za-z0-9_]") Then Exit Function
|
||||
Next i
|
||||
IsValidVBComponentName = True
|
||||
End Function
|
||||
|
||||
' Import all .bas files as standard modules (assumes validation passed)
|
||||
Private Sub ImportStandardModules(folderPath As String)
|
||||
Dim fso As Object, file As Object
|
||||
Set fso = CreateObject("Scripting.FileSystemObject")
|
||||
|
||||
Debug.Print "[LOG] Starting import of standard modules from: " & folderPath
|
||||
For Each file In fso.GetFolder(folderPath).Files
|
||||
If LCase(fso.GetExtensionName(file.Name)) = "bas" Then
|
||||
Dim modName As String
|
||||
modName = fso.GetBaseName(file.Name)
|
||||
Debug.Print "[LOG] Processing module: " & file.Path
|
||||
|
||||
' Remove existing module if any
|
||||
On Error Resume Next
|
||||
ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents(modName)
|
||||
On Error GoTo 0
|
||||
Debug.Print "[LOG] Removed existing module (if any): " & modName
|
||||
|
||||
' Import new one
|
||||
ThisWorkbook.VBProject.VBComponents.Import file.Path
|
||||
Debug.Print "[LOG] Successfully imported: " & file.Path
|
||||
End If
|
||||
Next file
|
||||
Debug.Print "[LOG] Finished importing standard modules."
|
||||
End Sub
|
||||
|
||||
' Import .cls files into worksheet code modules (by CodeName)
|
||||
Private Sub ImportSheetCLSFiles(folderPath As String)
|
||||
Dim fso As Object, file As Object
|
||||
Set fso = CreateObject("Scripting.FileSystemObject")
|
||||
|
||||
Debug.Print "[LOG] Starting import of sheet code modules from: " & folderPath
|
||||
For Each file In fso.GetFolder(folderPath).Files
|
||||
If LCase(fso.GetExtensionName(file.Name)) = "cls" Then
|
||||
Dim sheetCodeName As String
|
||||
sheetCodeName = fso.GetBaseName(file.Name)
|
||||
Debug.Print "[LOG] Processing sheet code: " & file.Path & " -> " & sheetCodeName
|
||||
|
||||
Dim cmp As Object
|
||||
Set cmp = ThisWorkbook.VBProject.VBComponents(sheetCodeName) ' Safe: already validated
|
||||
|
||||
Dim pureCode As String
|
||||
pureCode = ExtractPureCodeFromCls(file.Path)
|
||||
|
||||
With cmp.CodeModule
|
||||
If .CountOfLines > 0 Then .DeleteLines 1, .CountOfLines
|
||||
If Trim(pureCode) <> "" Then .AddFromString pureCode
|
||||
End With
|
||||
Debug.Print "[LOG] Successfully updated code for: " & sheetCodeName
|
||||
End If
|
||||
Next file
|
||||
Debug.Print "[LOG] Finished importing sheet code modules."
|
||||
End Sub
|
||||
|
||||
' Extract only the VBA source code from a .cls file (skip VERSION, BEGIN, Attribute lines)
|
||||
Private Function ExtractPureCodeFromCls(filePath As String) As String
|
||||
Dim fso As Object, ts As Object, line As String
|
||||
Set fso = CreateObject("Scripting.FileSystemObject")
|
||||
Set ts = fso.OpenTextFile(filePath, 1)
|
||||
|
||||
Dim result As String
|
||||
Dim inCodeSection As Boolean: inCodeSection = False
|
||||
|
||||
Do While Not ts.AtEndOfStream
|
||||
line = ts.ReadLine
|
||||
|
||||
If inCodeSection Then
|
||||
result = result & line & vbCrLf
|
||||
Else
|
||||
Dim tLine As String: tLine = Trim(line)
|
||||
If tLine = "" Then
|
||||
inCodeSection = True
|
||||
ElseIf Left(tLine, 7) = "VERSION" Or _
|
||||
Left(tLine, 5) = "BEGIN" Or _
|
||||
Left(tLine, 3) = "END" Or _
|
||||
Left(tLine, 9) = "Attribute" Then
|
||||
' Skip metadata lines
|
||||
Else
|
||||
inCodeSection = True
|
||||
result = result & line & vbCrLf
|
||||
End If
|
||||
End If
|
||||
Loop
|
||||
|
||||
ts.Close
|
||||
ExtractPureCodeFromCls = result
|
||||
End Function
|
||||
198
src/sh/tuk/init_module/Test_Cache.bas
Normal file
198
src/sh/tuk/init_module/Test_Cache.bas
Normal file
@@ -0,0 +1,198 @@
|
||||
Attribute VB_Name = "Test_Cache"
|
||||
Option Explicit
|
||||
' ============================================================
|
||||
' Module Name: Test_Cache
|
||||
' Module Desc: Debug module to print cache contents to Test_Cache sheet
|
||||
' Module Methods:
|
||||
' - Test_PrintAllCaches
|
||||
' - PrintM1CacheToSheet
|
||||
' - PrintM1KukanDCacheToSheet
|
||||
' - PrintM2CacheToSheet
|
||||
' - PrintZ1CacheToSheet
|
||||
' - PrintO1CacheToSheet
|
||||
' ============================================================
|
||||
|
||||
' Test Cache Module
|
||||
|
||||
Sub Test_PrintAllCaches()
|
||||
Call RefreshM1Cache
|
||||
Call RefreshM1KukanDCache
|
||||
Call RefreshM2Cache
|
||||
Call RefreshZ1Cache
|
||||
Call RefreshO1Cache
|
||||
|
||||
Dim ws As Worksheet
|
||||
On Error Resume Next
|
||||
Set ws = ThisWorkbook.Worksheets("Test_Cache")
|
||||
If ws Is Nothing Then
|
||||
Set ws = ThisWorkbook.Worksheets.Add
|
||||
ws.Name = "Test_Cache"
|
||||
End If
|
||||
On Error GoTo 0
|
||||
|
||||
ws.Cells.ClearContents
|
||||
|
||||
Dim r As Long
|
||||
r = 1
|
||||
ws.Cells(r, 1).Value = "M1 Cache"
|
||||
r = r + 1
|
||||
Call PrintM1CacheToSheet(ws, r)
|
||||
|
||||
r = r + 1
|
||||
ws.Cells(r, 1).Value = "M1_KukanD Cache"
|
||||
r = r + 1
|
||||
Call PrintM1KukanDCacheToSheet(ws, r)
|
||||
|
||||
r = r + 1
|
||||
ws.Cells(r, 1).Value = "M2 Cache"
|
||||
r = r + 1
|
||||
Call PrintM2CacheToSheet(ws, r)
|
||||
|
||||
r = r + 1
|
||||
ws.Cells(r, 1).Value = "Z1 Cache"
|
||||
r = r + 1
|
||||
Call PrintZ1CacheToSheet(ws, r)
|
||||
|
||||
r = r + 1
|
||||
ws.Cells(r, 1).Value = "O1 Cache"
|
||||
r = r + 1
|
||||
Call PrintO1CacheToSheet(ws, r)
|
||||
|
||||
ws.Columns.AutoFit
|
||||
End Sub
|
||||
|
||||
Private Sub PrintM1CacheToSheet(ws As Worksheet, ByRef r As Long)
|
||||
If m1Cache Is Nothing Then
|
||||
ws.Cells(r, 1).Value = "Nothing"
|
||||
r = r + 1
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
ws.Cells(r, 1).Value = "Count: " & m1Cache.Count
|
||||
r = r + 1
|
||||
|
||||
Dim k As Variant
|
||||
For Each k In m1Cache.Keys
|
||||
Dim v As Variant
|
||||
v = m1Cache(k)
|
||||
ws.Cells(r, 1).Value = k
|
||||
ws.Cells(r, 2).Value = v(1)
|
||||
ws.Cells(r, 3).Value = v(2)
|
||||
ws.Cells(r, 4).Value = v(3)
|
||||
r = r + 1
|
||||
Next k
|
||||
End Sub
|
||||
|
||||
Private Sub PrintM1KukanDCacheToSheet(ws As Worksheet, ByRef r As Long)
|
||||
If m1KukanDCache Is Nothing Then
|
||||
ws.Cells(r, 1).Value = "Nothing"
|
||||
r = r + 1
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
ws.Cells(r, 1).Value = "Count: " & m1KukanDCache.Count
|
||||
r = r + 1
|
||||
|
||||
Dim d As Variant
|
||||
For Each d In m1KukanDCache.Keys
|
||||
ws.Cells(r, 1).Value = d
|
||||
r = r + 1
|
||||
Dim inner As Object
|
||||
Set inner = m1KukanDCache(d)
|
||||
Dim f As Variant
|
||||
For Each f In inner.Keys
|
||||
ws.Cells(r, 2).Value = f
|
||||
r = r + 1
|
||||
Dim arr As Object
|
||||
Set arr = inner(f)
|
||||
Dim g As Variant
|
||||
For Each g In arr.Keys
|
||||
ws.Cells(r, 3).Value = g
|
||||
r = r + 1
|
||||
Next g
|
||||
Next f
|
||||
Next d
|
||||
End Sub
|
||||
|
||||
Private Sub PrintM2CacheToSheet(ws As Worksheet, ByRef r As Long)
|
||||
If m2Cache Is Nothing Then
|
||||
ws.Cells(r, 1).Value = "Nothing"
|
||||
r = r + 1
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
ws.Cells(r, 1).Value = "Count: " & m2Cache.Count
|
||||
r = r + 1
|
||||
|
||||
Dim k As Variant
|
||||
For Each k In m2Cache.Keys
|
||||
ws.Cells(r, 1).Value = k
|
||||
r = r + 1
|
||||
Dim inner As Object
|
||||
Set inner = m2Cache(k)
|
||||
Dim kanshu As Variant
|
||||
For Each kanshu In inner.Keys
|
||||
ws.Cells(r, 2).Value = kanshu
|
||||
r = r + 1
|
||||
Dim innermost As Object
|
||||
Set innermost = inner(kanshu)
|
||||
Dim c As Variant
|
||||
For Each c In innermost.Keys
|
||||
ws.Cells(r, 3).Value = c
|
||||
ws.Cells(r, 4).Value = innermost(c)
|
||||
r = r + 1
|
||||
Next c
|
||||
Next kanshu
|
||||
Next k
|
||||
End Sub
|
||||
|
||||
Private Sub PrintZ1CacheToSheet(ws As Worksheet, ByRef r As Long)
|
||||
If z1Cache Is Nothing Then
|
||||
ws.Cells(r, 1).Value = "Nothing"
|
||||
r = r + 1
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
ws.Cells(r, 1).Value = "Count: " & z1Cache.Count
|
||||
r = r + 1
|
||||
|
||||
Dim k As Variant
|
||||
For Each k In z1Cache.Keys
|
||||
Dim v As Variant
|
||||
v = z1Cache(k)
|
||||
ws.Cells(r, 1).Value = k
|
||||
ws.Cells(r, 2).Value = v(0)
|
||||
r = r + 1
|
||||
Next k
|
||||
End Sub
|
||||
|
||||
Private Sub PrintO1CacheToSheet(ws As Worksheet, ByRef r As Long)
|
||||
If o1Cache Is Nothing Then
|
||||
ws.Cells(r, 1).Value = "Nothing"
|
||||
r = r + 1
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
ws.Cells(r, 1).Value = "Count: " & o1Cache.Count
|
||||
r = r + 1
|
||||
|
||||
Dim c As Variant
|
||||
For Each c In o1Cache.Keys
|
||||
ws.Cells(r, 1).Value = c
|
||||
r = r + 1
|
||||
Dim inner As Object
|
||||
Set inner = o1Cache(c)
|
||||
Dim e As Variant
|
||||
For Each e In inner.Keys
|
||||
ws.Cells(r, 2).Value = e
|
||||
r = r + 1
|
||||
Dim arr As Object
|
||||
Set arr = inner(e)
|
||||
Dim f As Variant
|
||||
For Each f In arr.Keys
|
||||
ws.Cells(r, 3).Value = f
|
||||
r = r + 1
|
||||
Next f
|
||||
Next e
|
||||
Next c
|
||||
End Sub
|
||||
359
src/sh/tuk/module/Common_Button.bas
Normal file
359
src/sh/tuk/module/Common_Button.bas
Normal file
@@ -0,0 +1,359 @@
|
||||
Attribute VB_Name = "Common_Button"
|
||||
Option Explicit
|
||||
' ============================================================
|
||||
' Module Name: Common_Button
|
||||
' Module Desc: Common_Button
|
||||
' Module Methods:
|
||||
' - CSV_Import_Button
|
||||
' ============================================================
|
||||
Sub CSV_Import_Button()
|
||||
DO_CSV_Import ActiveSheet
|
||||
End Sub
|
||||
|
||||
Sub Validation_Button()
|
||||
Do_Validation ActiveSheet
|
||||
End Sub
|
||||
|
||||
Sub CSV_Export_Button()
|
||||
DO_CSV_Export ActiveSheet
|
||||
End Sub
|
||||
|
||||
Sub Sort_Button()
|
||||
Do_Sort ActiveSheet
|
||||
End Sub
|
||||
|
||||
Sub Filter_Button()
|
||||
Do_Filter ActiveSheet
|
||||
End Sub
|
||||
|
||||
Sub Fit_Button()
|
||||
Do_Fit ActiveSheet
|
||||
End Sub
|
||||
|
||||
Sub RefreshCache_Button()
|
||||
Dim cacheSheets As Variant: cacheSheets = Array("M1", "M2", "Z1", "Z2", "Z3", "Z4", "T1", "T2", "T3", "O1","O2")
|
||||
|
||||
Dim sheetName As Variant
|
||||
Dim ws As Worksheet
|
||||
For Each sheetName In cacheSheets
|
||||
If ProcedureExists(sheetName, "Validate") Then
|
||||
Dim errorCount As Long
|
||||
On Error Resume Next
|
||||
Set ws = ThisWorkbook.Worksheets(CStr(sheetName))
|
||||
On Error GoTo 0
|
||||
Dim isValid As Boolean: isValid = RunValidationSilent(ws, errorCount)
|
||||
If isValid = False Then
|
||||
MsgBox "Can't refresh " & sheetName & " cache. Validation error occurs."
|
||||
Exit Sub
|
||||
End If
|
||||
End If
|
||||
Next sheetName
|
||||
|
||||
Dim result As Boolean: result = RefreshAllCache()
|
||||
If result = True Then
|
||||
MsgBox "master data reload successfully."
|
||||
End If
|
||||
End Sub
|
||||
|
||||
Private Sub DO_CSV_Import(ws As Excel.Worksheet)
|
||||
On Error GoTo ImportError
|
||||
|
||||
' Step 1: get csv encoding
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim cfg As Object: Set cfg = sheetConfDict(ws.CodeName)
|
||||
Dim expectedColumnCount As Long: expectedColumnCount = cfg("ExpectedColumnCount")
|
||||
|
||||
' Step 2: Select CSV file
|
||||
Dim filePath As String: filePath = SelectCSVFile()
|
||||
If filePath = "" Then Exit Sub
|
||||
|
||||
' Step 3: Read CSV and return 2D array
|
||||
Dim csvData As Variant: csvData = ReadCSVAs2DArrayStrict(filePath, expectedColumnCount, cfg("CSV_Encoding"), cfg("HasHeader"))
|
||||
|
||||
If Not IsArray(csvData) Then
|
||||
MsgBox "No valid data returned from CSV.", vbExclamation
|
||||
GoTo FinallyExit
|
||||
End If
|
||||
|
||||
If UBound(csvData, 1) < 1 Then
|
||||
MsgBox "No data in CSV.", vbExclamation
|
||||
GoTo FinallyExit
|
||||
End If
|
||||
|
||||
' === Step 3:Clear all data rows before import ===
|
||||
Application.ScreenUpdating = False
|
||||
Application.EnableEvents = False
|
||||
Call ClearDataRows(ws)
|
||||
|
||||
' === Step 4: Write CSV data to worksheet ===
|
||||
Dim colLetters As Variant: colLetters = cfg("HeaderColumns")
|
||||
Dim writeRow As Long: writeRow = cfg("StartRow")
|
||||
Dim i As Long
|
||||
' loop row
|
||||
For i = LBound(csvData, 1) To UBound(csvData, 1)
|
||||
Dim j As Long
|
||||
' loop column
|
||||
For j = 0 To expectedColumnCount - 1
|
||||
ws.Cells(writeRow, ws.Range(colLetters(j) & "1").Column).Value = CleanCSVField(CStr(csvData(i, j + 1)))
|
||||
Next j
|
||||
writeRow = writeRow + 1
|
||||
Next i
|
||||
|
||||
' === Step 5: Trigger sheet-specific import handler ===
|
||||
If ProcedureExists(ws.CodeName, "ImportCSVAndTriggerChange") Then
|
||||
Call Application.Run(ws.CodeName & ".ImportCSVAndTriggerChange", ws, writeRow)
|
||||
End If
|
||||
|
||||
MsgBox writeRow - cfg("StartRow") & " rows imported.", vbInformation
|
||||
GoTo FinallyExit
|
||||
|
||||
ImportError:
|
||||
MsgBox "CSV import failed: " & Err.Description, vbExclamation
|
||||
|
||||
FinallyExit:
|
||||
Application.EnableEvents = True
|
||||
Application.ScreenUpdating = True
|
||||
End Sub
|
||||
|
||||
'
|
||||
Private Sub Do_Validation(ws As Excel.Worksheet)
|
||||
On Error GoTo ErrorHandler
|
||||
|
||||
' step1. confirm Validate Sub
|
||||
If Not ProcedureExists(ws.CodeName, "Validate") Then
|
||||
MsgBox "worksheet """ & ws.name & """ unimplement methods", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim errorCount As Long
|
||||
Dim isValid As Boolean: isValid = RunValidationSilent(ws, errorCount)
|
||||
|
||||
If errorCount = -1 Then
|
||||
MsgBox "worksheet """ & ws.Name & """ unimplement methods", vbExclamation
|
||||
ElseIf errorCount = -2 Then
|
||||
MsgBox "Validation error occurred.", vbCritical
|
||||
ElseIf errorCount > 0 Then
|
||||
MsgBox "Validation complete. Errors: " & errorCount, vbInformation
|
||||
Else
|
||||
If ws.CodeName <> "C1" Then
|
||||
RefreshCache(ws.CodeName)
|
||||
End If
|
||||
MsgBox "Validation complete. Errors: 0", vbInformation
|
||||
End If
|
||||
|
||||
Exit Sub
|
||||
|
||||
ErrorHandler:
|
||||
MsgBox "Error: " & Err.Description, vbCritical
|
||||
Exit Sub
|
||||
End Sub
|
||||
|
||||
'
|
||||
Private Sub DO_CSV_Export(ws As Excel.Worksheet)
|
||||
On Error GoTo ExportError
|
||||
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws)
|
||||
Dim startRow As Long: startRow = sheetConf("StartRow")
|
||||
|
||||
If lastDataRow < startRow Then
|
||||
MsgBox "No data rows to output.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' === Step 1: Validate all rows before export ===
|
||||
' Do_Validation
|
||||
Dim errorCount As Long
|
||||
If Not RunValidationSilent(ws, errorCount) Then
|
||||
If errorCount > 0 Then
|
||||
MsgBox "Validation failed (" & errorCount & " errors). Export aborted.", vbCritical
|
||||
Exit Sub
|
||||
Else
|
||||
MsgBox "Validation setup error. Export aborted.", vbCritical
|
||||
Exit Sub
|
||||
End If
|
||||
End If
|
||||
|
||||
' === Step 2: Select save path ===
|
||||
Dim savePath As String: savePath = GetSaveCSVPath()
|
||||
If savePath = "" Then Exit Sub
|
||||
|
||||
' === Step 3: Count data rows ===
|
||||
Dim rowCount As Long: rowCount = lastDataRow - startRow + 1
|
||||
|
||||
' === Step 4: Count data columns ===
|
||||
Dim expectedColumnCount As Long: expectedColumnCount = sheetConf("ExpectedColumnCount")
|
||||
|
||||
' === Step 5: check export csv has header ===
|
||||
Dim hasHeader As Boolean: hasHeader = sheetConf("HasHeader")
|
||||
Dim dataRow As Long: dataRow = 1
|
||||
Dim outputArr As Variant
|
||||
|
||||
' when has header + 1
|
||||
If hasHeader Then
|
||||
ReDim outputArr(1 To rowCount + 1, 1 To expectedColumnCount)
|
||||
Else
|
||||
ReDim outputArr(1 To rowCount, 1 To expectedColumnCount)
|
||||
End If
|
||||
|
||||
' === Step 6: Build array with header and data ===
|
||||
If hasHeader Then
|
||||
Dim headerArr As Variant
|
||||
headerArr = GetCSVHeader(ws)
|
||||
|
||||
Dim colIdx As Long
|
||||
For colIdx = 0 To expectedColumnCount - 1
|
||||
outputArr(1, colIdx + 1) = headerArr(1, colIdx + 1)
|
||||
Next colIdx
|
||||
dataRow = dataRow + 1
|
||||
End If
|
||||
|
||||
Dim colLetters As Variant: colLetters = sheetConf("HeaderColumns")
|
||||
Dim r As Long
|
||||
For r = startRow To lastDataRow
|
||||
For colIdx = 0 To expectedColumnCount - 1
|
||||
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, sheetConf("CSV_Encoding"), sheetConf("AlwaysQuote"))
|
||||
On Error GoTo 0
|
||||
|
||||
MsgBox "CSV export completed. Total data rows: " & rowCount, vbInformation
|
||||
Exit Sub
|
||||
|
||||
ExportError:
|
||||
MsgBox "CSV export failed: " & Err.Description, vbExclamation
|
||||
End Sub
|
||||
|
||||
Private Sub Do_Sort(ws As Excel.Worksheet)
|
||||
On Error GoTo ErrorHandler
|
||||
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim startCol As String: startCol = sheetConf("StartCol")
|
||||
Dim endCol As String: endCol = sheetConf("EndCol")
|
||||
Dim startRow As Long: startRow = sheetConf("StartRow")
|
||||
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws)
|
||||
|
||||
If lastDataRow < startRow Then
|
||||
MsgBox "No data to sort.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim sortRange As Range: Set sortRange = ws.Range(ws.Cells(startRow, ws.Range(startCol & "1").Column), ws.Cells(lastDataRow, ws.Range(endCol & "1").Column))
|
||||
sortRange.Select
|
||||
|
||||
' Show sort dialog
|
||||
Application.Dialogs(xlDialogSort).Show
|
||||
Exit Sub
|
||||
|
||||
ErrorHandler:
|
||||
MsgBox "Error: " & Err.Description, vbCritical
|
||||
End Sub
|
||||
|
||||
Private Sub Do_Filter(ws As Excel.Worksheet)
|
||||
On Error GoTo ErrorHandler
|
||||
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
' Check if auto filter is already on
|
||||
If ws.AutoFilterMode Then
|
||||
ws.AutoFilterMode = False
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim startCol As Long: startCol = ws.Range(sheetConf("StartCol") & "1").Column
|
||||
Dim endCol As Long: endCol = ws.Range(sheetConf("EndCol") & "1").Column
|
||||
|
||||
Dim filterRow As Long: filterRow = sheetConf("FilterRow")
|
||||
|
||||
Dim filterRange As Range: Set filterRange = ws.Range(ws.Cells(filterRow, startCol), ws.Cells(filterRow, endCol))
|
||||
filterRange.AutoFilter
|
||||
Exit Sub
|
||||
|
||||
ErrorHandler:
|
||||
MsgBox "Error: " & Err.Description, vbCritical
|
||||
End Sub
|
||||
|
||||
Private Sub Do_Fit(ws As Excel.Worksheet)
|
||||
On Error GoTo ErrorHandler
|
||||
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim startCol As String: startCol = sheetConf("StartCol")
|
||||
Dim endCol As String: endCol = sheetConf("EndCol")
|
||||
|
||||
ws.Columns(startCol & ":" & endCol).AutoFit
|
||||
Exit Sub
|
||||
|
||||
ErrorHandler:
|
||||
MsgBox "Error: " & Err.Description, vbCritical
|
||||
End Sub
|
||||
|
||||
' RunValidationSilent
|
||||
Public Function RunValidationSilent(ws As Worksheet, Optional ByRef errorCountOut As Long = 0) As Boolean
|
||||
On Error GoTo ErrorHandler
|
||||
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
' check Validate method exist
|
||||
If Not ProcedureExists(ws.CodeName, "Validate") Then
|
||||
errorCountOut = -1
|
||||
RunValidationSilent = False
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim validate As String: validate = ws.CodeName & ".Validate"
|
||||
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws)
|
||||
Dim startRow As Long: startRow = sheetConf("StartRow")
|
||||
Dim errorCol As Long: errorCol = ws.Range(sheetConf("ErrorCol") & "1").Column
|
||||
|
||||
If lastDataRow < startRow Then
|
||||
errorCountOut = 0
|
||||
RunValidationSilent = True
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim r As Long
|
||||
errorCountOut = 0
|
||||
For r = startRow To lastDataRow
|
||||
Application.Run validate, ws, r, lastDataRow
|
||||
Dim errorMessage As String : errorMessage = Trim(ws.Cells(r, errorCol).Value)
|
||||
Dim errorCode As String: errorCode = GetCode(errorMessage)
|
||||
If errorCode <> "W001" And errorCode <> "" Then
|
||||
errorCountOut = errorCountOut + 1
|
||||
End If
|
||||
Next r
|
||||
|
||||
RunValidationSilent = (errorCountOut = 0)
|
||||
Exit Function
|
||||
|
||||
ErrorHandler:
|
||||
errorCountOut = -2
|
||||
RunValidationSilent = False
|
||||
End Function
|
||||
|
||||
Public Function ProcedureExists(ByVal moduleName As String, ByVal procName As String) As Boolean
|
||||
Dim VBProj As Object, VBComp As Object, CodeMod As Object
|
||||
|
||||
On Error Resume Next
|
||||
|
||||
Set VBProj = ThisWorkbook.VBProject
|
||||
Set VBComp = VBProj.VBComponents(moduleName)
|
||||
If Not VBComp Is Nothing Then
|
||||
Set CodeMod = VBComp.CodeModule
|
||||
ProcedureExists = (CodeMod.ProcStartLine(procName, 0) > 0)
|
||||
End If
|
||||
|
||||
If Err.Number <> 0 Then ProcedureExists = False
|
||||
On Error GoTo 0
|
||||
End Function
|
||||
348
src/sh/tuk/module/Common_File_Utils.bas
Normal file
348
src/sh/tuk/module/Common_File_Utils.bas
Normal file
@@ -0,0 +1,348 @@
|
||||
Attribute VB_Name = "Common_File_Utils"
|
||||
Option Explicit
|
||||
' ============================================================
|
||||
' Module Name: Write_Common
|
||||
' Module Desc: CSV write functions
|
||||
' Module Methods:
|
||||
' - GetSaveCSVPath
|
||||
' - WriteCSVFromArray
|
||||
' ============================================================
|
||||
|
||||
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
|
||||
field = GetCode(field)
|
||||
|
||||
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
|
||||
|
||||
' ============================================================
|
||||
' Module Name: Read_Common
|
||||
' Module Desc: CSV read functions
|
||||
' Module Methods:
|
||||
' - SelectCSVFile
|
||||
' - ReadCSVAs2DArrayStrict
|
||||
' - ParseCSVLines
|
||||
' ============================================================
|
||||
|
||||
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
|
||||
|
||||
' === standardize ===
|
||||
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
|
||||
|
||||
If lines.Count = 1 Then
|
||||
If hasHeader Then
|
||||
Err.Raise 5005, , "CSV file data is empty."
|
||||
End If
|
||||
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
|
||||
Dim startRow As Long
|
||||
If hasHeader Then
|
||||
startRow = 2
|
||||
Else
|
||||
startRow = 1
|
||||
End If
|
||||
|
||||
ReDim result(startRow To lines.Count, 1 To expectedColumnCount)
|
||||
|
||||
For i = startRow 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
|
||||
' Clean field before adding
|
||||
currentField = Trim(currentField)
|
||||
currentField = Replace(currentField, vbCr, "")
|
||||
currentField = Replace(currentField, vbLf, "")
|
||||
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
|
||||
' Clean field before adding
|
||||
currentField = Trim(currentField)
|
||||
currentField = Replace(currentField, vbCr, "")
|
||||
currentField = Replace(currentField, vbLf, "")
|
||||
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
|
||||
486
src/sh/tuk/module/Common_Functions.bas
Normal file
486
src/sh/tuk/module/Common_Functions.bas
Normal file
@@ -0,0 +1,486 @@
|
||||
Attribute VB_Name = "Common_Functions"
|
||||
Option Explicit
|
||||
' ============================================================
|
||||
' Module Name: Module_Common
|
||||
' Module Desc: Common utility functions for all modules
|
||||
' Module Methods:
|
||||
' - GetLastDataRowInRange
|
||||
' - ClearDataRows
|
||||
' - ClearDataRow
|
||||
' ============================================================
|
||||
|
||||
' Common Functions
|
||||
|
||||
' Get CSV header from specified row and columns
|
||||
Function GetCSVHeader(ByVal ws As Worksheet) As Variant
|
||||
On Error GoTo ErrorHandler
|
||||
'
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim colLetters As Variant: colLetters = sheetConf("HeaderColumns")
|
||||
Dim headerRow As Long: headerRow = sheetConf("HeaderRow")
|
||||
|
||||
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
|
||||
Dim colIndex As Long
|
||||
colIndex = Columns(colLetters(i)).Column
|
||||
|
||||
cellValue = Trim(ws.Cells(headerRow, colIndex).Value)
|
||||
cellValue = Replace(cellValue, vbLf, "")
|
||||
cellValue = Replace(cellValue, vbCr, "")
|
||||
cellValue = Replace(cellValue, vbCrLf, "")
|
||||
headerArr(1, i + 1) = cellValue
|
||||
Next i
|
||||
|
||||
GetCSVHeader = headerArr
|
||||
Exit Function
|
||||
|
||||
ErrorHandler:
|
||||
Err.Raise 1005, "GetCSVHeader", "Invalid column letter in HeaderColumns: '" & colLetters(i) & "'"
|
||||
End Function
|
||||
|
||||
'
|
||||
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
|
||||
|
||||
Function Contains(ByVal arr As Variant, ByVal value As String) As Boolean
|
||||
Dim i As Long
|
||||
For i = 0 To UBound(arr)
|
||||
If arr(i) = value Then
|
||||
Contains = True
|
||||
Exit Function
|
||||
End If
|
||||
Next i
|
||||
|
||||
Contains = False
|
||||
End Function
|
||||
|
||||
' @return dict : key = keyCol，value = Array
|
||||
' @param sheetName
|
||||
' @param keyCol
|
||||
' @param valueCols Array(4,5,6)
|
||||
' @param startRow default is 7
|
||||
Function LoadLookup(ByVal sheetName As String, ByVal cacheName As String) As Object
|
||||
On Error GoTo ErrHandler
|
||||
|
||||
' --- validate ---
|
||||
If Trim(sheetName) = "" Then Err.Raise 0001, "LoadLookup", "Sheet name cannot be empty."
|
||||
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
If Not sheetConfDict.Exists(sheetName) Then
|
||||
Err.Raise 1004, "LoadLookup", "Sheet not configured: " & sheetName
|
||||
End If
|
||||
|
||||
' --- obtain worksheet ---
|
||||
On Error Resume Next
|
||||
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(sheetName)
|
||||
If ws Is Nothing Then Err.Raise 0003, "LoadLookup", "Worksheet named '" & sheetName & "' not found."
|
||||
On Error GoTo ErrHandler
|
||||
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(cacheName)
|
||||
Dim startRow As Long: startRow = sheetConf("StartRow")
|
||||
Dim keyCol As Long: keyCol = sheetConf("KeyCol")
|
||||
Dim valueCols As Variant: valueCols = sheetConf("ValueCols")
|
||||
|
||||
Dim lastRow As Long
|
||||
If sheetName <> cacheName Then
|
||||
lastRow = ws.Cells(ws.Rows.Count, keyCol).End(xlUp).Row
|
||||
Else
|
||||
lastRow = GetLastDataRowInRange(ws)
|
||||
End If
|
||||
|
||||
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
|
||||
If lastRow < startRow Then
|
||||
Set LoadLookup = dict
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim nValCols As Long: nValCols = UBound(valueCols) - LBound(valueCols) + 1
|
||||
If nValCols = 0 Then Err.Raise 0002, "LoadLookup", "Value columns parameter is invalid."
|
||||
|
||||
' --- 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 ---
|
||||
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
|
||||
Exit Function
|
||||
|
||||
ErrHandler:
|
||||
Err.Raise Err.Number, Err.Source, Err.Description
|
||||
End Function
|
||||
|
||||
' obtain
|
||||
Function GetLastDataRowInRange(ws As Worksheet) As Long
|
||||
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
|
||||
If sheetConfDict.Exists(ws.CodeName) Then
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim startCol As Long, endCol As Long, startRow As Long
|
||||
On Error GoTo InvalidColumn
|
||||
startCol = ws.Range(sheetConf("StartCol") & "1").Column
|
||||
endCol = ws.Range(sheetConf("EndCol") & "1").Column
|
||||
startRow = sheetConf("StartRow")
|
||||
On Error GoTo 0
|
||||
|
||||
' --- 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
|
||||
Else
|
||||
Err.Raise 1004, "GetLastDataRowInRange", "Sheet not configured: " & ws.CodeName
|
||||
End If
|
||||
Exit Function
|
||||
|
||||
InvalidColumn:
|
||||
Err.Raise 1005, "GetLastDataRowInRange", "Invalid column letter for sheet: " & ws.CodeName
|
||||
End Function
|
||||
|
||||
Function ClearDataRow(ByVal ws As Worksheet, ByVal startCol As Long, ByVal endCol As Long, ByVal rowRow As Long, Optional ByVal errorCol As Long = 2)
|
||||
If rowRow >= 7 Then
|
||||
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowRow, startCol), ws.Cells(rowRow, endCol))
|
||||
clearRange.ClearContents
|
||||
clearRange.Interior.Color = vbWhite
|
||||
ws.Range(ws.Cells(rowRow, errorCol), ws.Cells(rowRow, errorCol)).ClearContents
|
||||
End If
|
||||
End Function
|
||||
|
||||
Sub ClearDataRows(ByVal ws As Worksheet)
|
||||
'
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
'
|
||||
If Not sheetConfDict.Exists(ws.CodeName) Then
|
||||
Err.Raise 1004, "ClearDataRows", "Sheet not configured: " & ws.CodeName
|
||||
End If
|
||||
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim startRow As Long: startRow = sheetConf("StartRow")
|
||||
Dim startCol As String: startCol = sheetConf("StartCol")
|
||||
Dim endCol As String: endCol = sheetConf("EndCol")
|
||||
Dim errorCol As String: errorCol = sheetConf("ErrorCol")
|
||||
'
|
||||
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws)
|
||||
|
||||
'
|
||||
If lastDataRow >= startRow Then
|
||||
Dim clearRange As Range
|
||||
Set clearRange = ws.Range(ws.Cells(startRow, ws.Range(startCol & "1").Column), ws.Cells(lastDataRow, ws.Range(endCol & "1").Column))
|
||||
clearRange.ClearContents
|
||||
clearRange.Interior.Color = vbWhite
|
||||
|
||||
If errorCol <> "" Then
|
||||
Dim clearErrorRange As Range
|
||||
Set clearErrorRange = ws.Range(ws.Cells(startRow, ws.Range(errorCol & "1").Column), ws.Cells(lastDataRow, ws.Range(errorCol & "1").Column))
|
||||
clearErrorRange.ClearContents
|
||||
clearErrorRange.Interior.Color = vbWhite
|
||||
End If
|
||||
End If
|
||||
End Sub
|
||||
|
||||
' Format: code:value (no space around colon)
|
||||
Function MakeSelect(ByVal code As String, ByVal value As String) As String
|
||||
MakeSelect = Trim(code) & ":" & Trim(value)
|
||||
End Function
|
||||
|
||||
' Get left part of MakeSelect format (e.g., "1:JR" -> "1")
|
||||
Function GetCode(ByVal text As String) As String
|
||||
Dim pos As Long: pos = InStr(text, ":")
|
||||
If pos > 0 Then
|
||||
GetCode = Left(text, pos - 1)
|
||||
Else
|
||||
GetCode = text
|
||||
End If
|
||||
End Function
|
||||
|
||||
' ============================================================
|
||||
' Format date input: YYYYMMDD or YYMMDD -> YYYY-MM-DD
|
||||
' ============================================================
|
||||
Public Function FormatDateInput(ByVal inputStr As String) As String
|
||||
Dim s As String: s = Trim(inputStr)
|
||||
If s = "" Then Exit Function
|
||||
|
||||
' Only process pure digit strings
|
||||
If Not IsNumeric(s) Then
|
||||
FormatDateInput = inputStr
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim yearPart As String, monthPart As String, dayPart As String
|
||||
Dim dateStr As String
|
||||
|
||||
If Len(s) = 8 Then
|
||||
' YYYYMMDD format
|
||||
yearPart = Left(s, 4)
|
||||
monthPart = Mid(s, 5, 2)
|
||||
dayPart = Right(s, 2)
|
||||
ElseIf Len(s) = 6 Then
|
||||
' YYMMDD format - add 20 prefix
|
||||
yearPart = "20" & Left(s, 2)
|
||||
monthPart = Mid(s, 3, 2)
|
||||
dayPart = Right(s, 2)
|
||||
Else
|
||||
FormatDateInput = inputStr
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
' Build date string and validate
|
||||
dateStr = yearPart & "-" & monthPart & "-" & dayPart
|
||||
|
||||
If IsDate(dateStr) Then
|
||||
FormatDateInput = dateStr
|
||||
Else
|
||||
FormatDateInput = inputStr
|
||||
End If
|
||||
End Function
|
||||
|
||||
Function CheckHeaderEdit(ByVal ws As Worksheet, ByVal Target As Range) As Boolean
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
Dim headerRow As Long: headerRow = sheetConf("HeaderRow")
|
||||
|
||||
' Check header row (headerRow) cannot be edited
|
||||
If Target.Row = headerRow Then
|
||||
Application.EnableEvents = False
|
||||
MsgBox "Header row can not be edit", vbExclamation
|
||||
Application.Undo
|
||||
Application.EnableEvents = True
|
||||
|
||||
CheckHeaderEdit = True
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
CheckHeaderEdit = False
|
||||
End Function
|
||||
|
||||
Function GetErrorMsg(ByVal errorCode As String, Optional ByVal param0 As String = "", Optional ByVal param1 As String = "") As String
|
||||
Dim errorList As Object: Set errorList = GetCache("errorList")
|
||||
Dim errorMessage As String
|
||||
If errorList.Exists(errorCode) Then
|
||||
errorMessage = Replace(errorList(errorCode)(0), "{0}", param0)
|
||||
errorMessage = Replace(errorMessage, "{1}", param1)
|
||||
errorMessage = MakeSelect(errorCode, errorMessage)
|
||||
End If
|
||||
GetErrorMsg = errorMessage
|
||||
End Function
|
||||
|
||||
Function ColLetter(colNum As Long) As String
|
||||
ColLetter = Split(Cells(1, colNum).Address, "$")(1)
|
||||
End Function
|
||||
|
||||
Function CheckRequired(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String) As Boolean
|
||||
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
|
||||
If checkValue = "" Then
|
||||
Dim letter As String: letter = ColLetter(colNum)
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", letter & rowNum)
|
||||
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
|
||||
CheckRequired = False
|
||||
Exit Function
|
||||
End If
|
||||
CheckRequired = True
|
||||
End Function
|
||||
|
||||
Function CheckChar(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal charLength As Long, ByVal errorCol As String)
|
||||
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
|
||||
If Len(checkValue) <> charLength Then
|
||||
Dim letter As String: letter = ColLetter(colNum)
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E006", letter & rowNum, charLength)
|
||||
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
|
||||
CheckChar = False
|
||||
Exit Function
|
||||
End If
|
||||
CheckChar = True
|
||||
End Function
|
||||
|
||||
Function CheckAlphanumeric(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal charLength As Long, ByVal errorCol As String)
|
||||
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
|
||||
Dim letter As String: letter = ColLetter(colNum)
|
||||
Dim i As Long
|
||||
Dim ch As String
|
||||
For i = 1 To charLength
|
||||
ch = Mid(checkValue, 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, errorCol).Value = GetErrorMsg("E005", letter & rowNum)
|
||||
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
|
||||
CheckAlphanumeric = False
|
||||
Exit Function
|
||||
End If
|
||||
Next i
|
||||
|
||||
CheckAlphanumeric = True
|
||||
End Function
|
||||
|
||||
Function CheckVarcharOver(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal varcharLength As Long, ByVal errorCol As String)
|
||||
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
|
||||
If Len(checkValue) > varcharLength Then
|
||||
Dim letter As String: letter = ColLetter(colNum)
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E007", letter & rowNum)
|
||||
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
|
||||
CheckVarcharOver = False
|
||||
Exit Function
|
||||
End If
|
||||
CheckVarcharOver = True
|
||||
End Function
|
||||
|
||||
Function CheckNumberOver(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal numberLength As Long, ByVal errorCol As String)
|
||||
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
|
||||
If Len(checkValue) > numberLength Then
|
||||
Dim letter As String: letter = ColLetter(colNum)
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E014", letter & rowNum, numberLength)
|
||||
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
|
||||
CheckNumberOver = False
|
||||
Exit Function
|
||||
End If
|
||||
CheckNumberOver = True
|
||||
End Function
|
||||
|
||||
Function Check01(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String)
|
||||
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
|
||||
Dim letter As String: letter = ColLetter(colNum)
|
||||
If checkValue <> "" Then
|
||||
If Len(checkValue) <> 1 Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E001", letter & rowNum)
|
||||
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
|
||||
Check01 = False
|
||||
Exit Function
|
||||
End If
|
||||
If checkValue <> "0" And checkValue <> "1" Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E008", letter & rowNum)
|
||||
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
|
||||
Check01 = False
|
||||
Exit Function
|
||||
End If
|
||||
End If
|
||||
Check01 = True
|
||||
End Function
|
||||
|
||||
Function Check12(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String)
|
||||
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
|
||||
Dim letter As String: letter = ColLetter(colNum)
|
||||
If checkValue <> "" Then
|
||||
If Len(checkValue) <> 1 Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E001", letter & rowNum)
|
||||
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
|
||||
Check12 = False
|
||||
Exit Function
|
||||
End If
|
||||
If checkValue <> "1" And checkValue <> "2" Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E009", letter & rowNum)
|
||||
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
|
||||
Check12 = False
|
||||
Exit Function
|
||||
End If
|
||||
End If
|
||||
Check12 = True
|
||||
End Function
|
||||
|
||||
Function CheckDuplicate(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String) As Boolean
|
||||
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
|
||||
Dim letter As String: letter = ColLetter(colNum)
|
||||
Dim i As Long
|
||||
|
||||
For i = 7 To rowNum - 1
|
||||
If Trim(ws.Cells(i, colNum).Value) = checkValue Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E010", letter & rowNum, checkValue)
|
||||
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
|
||||
CheckDuplicate = False
|
||||
Exit Function
|
||||
End If
|
||||
Next i
|
||||
|
||||
CheckDuplicate = True
|
||||
End Function
|
||||
|
||||
Function CheckNumber(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String) As Boolean
|
||||
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
|
||||
Dim letter As String: letter = ColLetter(colNum)
|
||||
|
||||
If checkValue = "" Then
|
||||
CheckNumber = True
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
If Not IsNumeric(checkValue) Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E011", letter & rowNum)
|
||||
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
|
||||
CheckNumber = False
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
CheckNumber = True
|
||||
End Function
|
||||
587
src/sh/tuk/module/Common_Global_Cache.bas
Normal file
587
src/sh/tuk/module/Common_Global_Cache.bas
Normal file
@@ -0,0 +1,587 @@
|
||||
Attribute VB_Name = "Common_Global_Cache"
|
||||
Option Explicit
|
||||
' ============================================================
|
||||
' Module Name: Global_Cache
|
||||
' Module Desc: Global Cache Module, Shared caches across all worksheets
|
||||
' Module Methods:
|
||||
' - RefreshM1KukanDCache
|
||||
' - RefreshM2Cache
|
||||
' - RefreshO1Cache
|
||||
' ============================================================
|
||||
Private sheetConfDict As Object
|
||||
|
||||
Public GlobalCache As Object
|
||||
|
||||
Public Sub InitCacheManager()
|
||||
If GlobalCache Is Nothing Then
|
||||
Set GlobalCache = CreateObject("Scripting.Dictionary")
|
||||
GlobalCache.CompareMode = vbTextCompare
|
||||
End If
|
||||
End Sub
|
||||
|
||||
Public Function GetCache(ByVal cacheName As String) As Object
|
||||
Dim cache As Object
|
||||
Dim loadedData As Object
|
||||
|
||||
'
|
||||
On Error GoTo RefreshError
|
||||
|
||||
'
|
||||
If GlobalCache Is Nothing Then InitCacheManager
|
||||
|
||||
'
|
||||
If Not GlobalCache.Exists(cacheName) Then
|
||||
Set GlobalCache(cacheName) = CreateObject("Scripting.Dictionary")
|
||||
GlobalCache(cacheName).CompareMode = vbTextCompare
|
||||
End If
|
||||
|
||||
Set cache = GlobalCache(cacheName)
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
If cache.Count = 0 Then
|
||||
If cacheName = "M1KukanDCache" Then
|
||||
Set loadedData = LookupM1KukanCache()
|
||||
ElseIf cacheName = "M2" Then
|
||||
Set loadedData = LookupM2Cache()
|
||||
ElseIf cacheName = "O1" Then
|
||||
Set loadedData = LookupO1Cache()
|
||||
ElseIf Contains(sheetConfDict("Enum"), cacheName) Then
|
||||
Set loadedData = LoadLookup("Enum", cacheName)
|
||||
Else
|
||||
Set loadedData = LoadLookup(cacheName, cacheName)
|
||||
End If
|
||||
|
||||
If Not loadedData Is Nothing Then
|
||||
Set GlobalCache(cacheName) = loadedData
|
||||
Set cache = loadedData
|
||||
End If
|
||||
End If
|
||||
|
||||
Set GetCache = cache
|
||||
Exit Function
|
||||
|
||||
RefreshError:
|
||||
Err.Raise 1001, "GetCache", "Failed to load " & cacheName & " lookup cache: " & Err.Description
|
||||
End Function
|
||||
|
||||
' before RefreshCache, should validate
|
||||
Public Sub RefreshCache(ByVal cacheName As String)
|
||||
Dim loadedData As Object
|
||||
|
||||
'
|
||||
On Error GoTo RefreshError
|
||||
|
||||
'
|
||||
If GlobalCache Is Nothing Then InitCacheManager
|
||||
|
||||
'
|
||||
If Not GlobalCache.Exists(cacheName) Then
|
||||
Set GlobalCache(cacheName) = CreateObject("Scripting.Dictionary")
|
||||
GlobalCache(cacheName).CompareMode = vbTextCompare
|
||||
End If
|
||||
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
If cacheName = "M1KukanDCache" Then
|
||||
Set loadedData = LookupM1KukanCache()
|
||||
ElseIf cacheName = "M2" Then
|
||||
Set loadedData = LookupM2Cache()
|
||||
ElseIf cacheName = "O1" Then
|
||||
Set loadedData = LookupO1Cache()
|
||||
ElseIf Contains(sheetConfDict("Enum"), cacheName) Then
|
||||
Set loadedData = LoadLookup("Enum", cacheName)
|
||||
Else
|
||||
Set loadedData = LoadLookup(cacheName, cacheName)
|
||||
End If
|
||||
|
||||
If Not loadedData Is Nothing Then
|
||||
Set GlobalCache(cacheName) = loadedData
|
||||
End If
|
||||
|
||||
Exit Sub
|
||||
|
||||
RefreshError:
|
||||
Err.Raise 1001, "RefreshCache", "Failed to load " & cacheName & " lookup cache: " & Err.Description
|
||||
End Sub
|
||||
|
||||
' Refresh M1_KukanD cache - nested dict {D: {F: [G]}}
|
||||
' Structure: { 交通機関区分[D]: { 利用区間発名[F]: [利用区間着名G] } }
|
||||
Private Function LookupM1KukanCache()
|
||||
Dim resultCache As Object
|
||||
Set resultCache = CreateObject("Scripting.Dictionary")
|
||||
|
||||
On Error GoTo ErrHandler
|
||||
|
||||
Dim ws As Worksheet
|
||||
On Error Resume Next
|
||||
Set ws = ThisWorkbook.Worksheets("M1")
|
||||
On Error GoTo ErrHandler
|
||||
|
||||
If ws Is Nothing Then
|
||||
Set LookupM1KukanCache = resultCache
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict("M1")
|
||||
Dim startRow As Long: startRow = sheetConf("StartRow")
|
||||
Dim lastRow As Long: lastRow = GetLastDataRowInRange(ws)
|
||||
If lastRow < startRow Then
|
||||
Set LookupM2Cache = resultCache
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim r As Long
|
||||
For r = startRow To lastRow
|
||||
Dim dValue As String: dValue = Trim(ws.Cells(r, 4).Value) ' D column
|
||||
Dim fValue As String: fValue = Trim(ws.Cells(r, 6).Value) ' F column
|
||||
Dim gValue As String: gValue = Trim(ws.Cells(r, 7).Value) ' G column
|
||||
|
||||
If dValue = "" Or fValue = "" Then GoTo NextRow2
|
||||
|
||||
' Outer level: D column (交通機関区分)
|
||||
If Not resultCache.Exists(dValue) Then
|
||||
Dim innerDict As Object: Set innerDict = CreateObject("Scripting.Dictionary")
|
||||
resultCache.Add dValue, innerDict
|
||||
End If
|
||||
|
||||
' Inner level: F column (利用区間発名) -> array of G values
|
||||
Set innerDict = resultCache(dValue)
|
||||
If Not innerDict.Exists(fValue) Then
|
||||
Dim arr As Object: Set arr = CreateObject("Scripting.Dictionary")
|
||||
innerDict.Add fValue, arr
|
||||
End If
|
||||
|
||||
Set arr = innerDict(fValue)
|
||||
If gValue <> "" And Not arr.Exists(gValue) Then
|
||||
arr.Add gValue, True
|
||||
End If
|
||||
|
||||
NextRow2:
|
||||
Next r
|
||||
|
||||
Set LookupM1KukanCache = resultCache
|
||||
Exit Function
|
||||
|
||||
ErrHandler:
|
||||
Err.Raise Err.Number, Err.Source, Err.Description
|
||||
End Function
|
||||
|
||||
' ============================================================
|
||||
' M2 Cache - Nested Dictionary
|
||||
' Structure: { 区間コード[C]: { 券種[I]: { コード[J]: K } } }
|
||||
' ============================================================
|
||||
Private Function LookupM2Cache() As Object
|
||||
Dim resultCache As Object
|
||||
Set resultCache = CreateObject("Scripting.Dictionary")
|
||||
|
||||
On Error GoTo ErrHandler
|
||||
|
||||
Dim ws As Worksheet
|
||||
On Error Resume Next
|
||||
Set ws = ThisWorkbook.Worksheets("M2")
|
||||
On Error GoTo ErrHandler
|
||||
|
||||
If ws Is Nothing Then
|
||||
Set LookupM2Cache = resultCache
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict("M2")
|
||||
Dim startRow As Long: startRow = sheetConf("StartRow")
|
||||
Dim lastRow As Long: lastRow = GetLastDataRowInRange(ws)
|
||||
If lastRow < startRow Then
|
||||
Set LookupM2Cache = resultCache
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim r As Long
|
||||
For r = startRow To lastRow
|
||||
Dim kukanCode As String: kukanCode = Trim(ws.Cells(r, 3).Value) ' C column
|
||||
Dim kanshu As String: kanshu = Trim(ws.Cells(r, 9).Value) ' I column
|
||||
Dim code As String: code = Trim(ws.Cells(r, 10).Value) ' J column
|
||||
Dim name As String: name = Trim(ws.Cells(r, 11).Value) ' K column
|
||||
|
||||
If kukanCode = "" Or kanshu = "" Or code = "" Then GoTo NextRow
|
||||
|
||||
' Outer level: kukanCode
|
||||
If Not resultCache.Exists(kukanCode) Then
|
||||
Dim innerDict As Object: Set innerDict = CreateObject("Scripting.Dictionary")
|
||||
resultCache.Add kukanCode, innerDict
|
||||
End If
|
||||
|
||||
' Middle level: kanshu
|
||||
Set innerDict = resultCache(kukanCode)
|
||||
If Not innerDict.Exists(kanshu) Then
|
||||
Dim innermostDict As Object: Set innermostDict = CreateObject("Scripting.Dictionary")
|
||||
innerDict.Add kanshu, innermostDict
|
||||
End If
|
||||
|
||||
' Inner level: code -> name
|
||||
Set innermostDict = innerDict(kanshu)
|
||||
If Not innermostDict.Exists(code) Then
|
||||
innermostDict.Add code, name
|
||||
End If
|
||||
|
||||
NextRow:
|
||||
Next r
|
||||
|
||||
Set LookupM2Cache = resultCache
|
||||
Exit Function
|
||||
|
||||
ErrHandler:
|
||||
Err.Raise Err.Number, Err.Source, Err.Description
|
||||
End Function
|
||||
|
||||
' ============================================================
|
||||
' O1 Cache
|
||||
' ============================================================
|
||||
Private Function LookupO1Cache() As Object
|
||||
Dim resultCache As Object
|
||||
Set resultCache = CreateObject("Scripting.Dictionary")
|
||||
|
||||
Dim ws As Worksheet
|
||||
On Error Resume Next
|
||||
Set ws = ThisWorkbook.Worksheets("O1")
|
||||
On Error GoTo ErrHandler
|
||||
|
||||
If ws Is Nothing Then
|
||||
Set LookupO1Cache = resultCache
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict("O1")
|
||||
Dim startRow As Long: startRow = sheetConf("StartRow")
|
||||
Dim lastRow As Long: lastRow = GetLastDataRowInRange(ws)
|
||||
If lastRow < startRow Then
|
||||
Set LookupO1Cache = resultCache
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim r As Long
|
||||
For r = startRow To lastRow
|
||||
Dim cVal As String
|
||||
cVal = Trim(ws.Cells(r, 3).Value) ' C column
|
||||
Dim eVal As String
|
||||
eVal = Trim(ws.Cells(r, 5).Value) ' E column
|
||||
Dim fVal As String
|
||||
fVal = Trim(ws.Cells(r, 6).Value) ' F column
|
||||
|
||||
If cVal = "" Or eVal = "" Then GoTo NextO1
|
||||
|
||||
' Outer: C column
|
||||
If Not resultCache.Exists(cVal) Then
|
||||
Dim innerDict As Object
|
||||
Set innerDict = CreateObject("Scripting.Dictionary")
|
||||
resultCache.Add cVal, innerDict
|
||||
End If
|
||||
|
||||
' Inner: E column -> array of F values
|
||||
Set innerDict = resultCache(cVal)
|
||||
If Not innerDict.Exists(eVal) Then
|
||||
Dim arr As Object
|
||||
Set arr = CreateObject("Scripting.Dictionary")
|
||||
innerDict.Add eVal, arr
|
||||
End If
|
||||
|
||||
Set arr = innerDict(eVal)
|
||||
If Not arr.Exists(fVal) Then
|
||||
arr.Add fVal, True
|
||||
End If
|
||||
|
||||
NextO1:
|
||||
Next r
|
||||
|
||||
Set LookupO1Cache = resultCache
|
||||
Exit Function
|
||||
|
||||
ErrHandler:
|
||||
Err.Raise Err.Number, Err.Source, Err.Description
|
||||
End Function
|
||||
|
||||
Private Sub RefreshSheetDict()
|
||||
Debug.Print "RefreshSheetDict begin."
|
||||
Set sheetConfDict = CreateObject("Scripting.Dictionary")
|
||||
Dim sheetConf As Object
|
||||
|
||||
' C1
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartCol") = "C"
|
||||
sheetConf("EndCol") = "BC"
|
||||
sheetConf("ErrorCol") = "BD"
|
||||
sheetConf("StartRow") = 8
|
||||
sheetConf("HeaderRow") = 6
|
||||
sheetConf("CSV_Encoding") = "shift_jis"
|
||||
sheetConf("HasHeader") = True
|
||||
sheetConf("ExpectedColumnCount") = 41
|
||||
sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "W", "X", "Y", "Z", "AD", "AE", "AF", "AG", "AK", "AL", "AM", "AN", "AR", "AS", "AT", "AU", "AV", "AW", "AX", "AY", "AZ", "BA", "BB", "BC")
|
||||
sheetConf("AlwaysQuote") = False
|
||||
sheetConf("FilterRow") = 7
|
||||
Set sheetConfDict("C1") = sheetConf
|
||||
Debug.Print "RefreshSheetDict C1 ok."
|
||||
|
||||
' M1
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartCol") = "C"
|
||||
sheetConf("EndCol") = "N"
|
||||
sheetConf("ErrorCol") = "O"
|
||||
sheetConf("StartRow") = 7
|
||||
sheetConf("HeaderRow") = 5
|
||||
sheetConf("CacheName") = "m1Cache"
|
||||
sheetConf("CSV_Encoding") = "shift_jis"
|
||||
sheetConf("HasHeader") = True
|
||||
sheetConf("ExpectedColumnCount") = 12
|
||||
sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N")
|
||||
sheetConf("AlwaysQuote") = False
|
||||
sheetConf("FilterRow") = 6
|
||||
sheetConf("KeyCol") = 3
|
||||
sheetConf("ValueCols") = Array(3, 4, 5, 6, 7, 9, 12)
|
||||
Set sheetConfDict("M1") = sheetConf
|
||||
Debug.Print "RefreshSheetDict M1 ok."
|
||||
|
||||
' M2
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartCol") = "C"
|
||||
sheetConf("EndCol") = "R"
|
||||
sheetConf("ErrorCol") = "S"
|
||||
sheetConf("StartRow") = 7
|
||||
sheetConf("HeaderRow") = 6
|
||||
sheetConf("CSV_Encoding") = "shift_jis"
|
||||
sheetConf("HasHeader") = True
|
||||
sheetConf("ExpectedColumnCount") = 11
|
||||
sheetConf("HeaderColumns") = Array("C", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R")
|
||||
sheetConf("AlwaysQuote") = False
|
||||
sheetConf("FilterRow") = 6
|
||||
Set sheetConfDict("M2") = sheetConf
|
||||
Debug.Print "RefreshSheetDict M2 ok."
|
||||
|
||||
' Z1
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartCol") = "C"
|
||||
sheetConf("EndCol") = "I"
|
||||
sheetConf("ErrorCol") = "B"
|
||||
sheetConf("StartRow") = 7
|
||||
sheetConf("HeaderRow") = 5
|
||||
sheetConf("CSV_Encoding") = "utf-8"
|
||||
sheetConf("HasHeader") = False
|
||||
sheetConf("ExpectedColumnCount") = 7
|
||||
sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I")
|
||||
sheetConf("AlwaysQuote") = True
|
||||
sheetConf("FilterRow") = 6
|
||||
sheetConf("KeyCol") = 3
|
||||
sheetConf("ValueCols") = Array(4)
|
||||
Set sheetConfDict("Z1") = sheetConf
|
||||
Debug.Print "RefreshSheetDict Z1 ok."
|
||||
|
||||
' Z2
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartCol") = "C"
|
||||
sheetConf("EndCol") = "G"
|
||||
sheetConf("ErrorCol") = "B"
|
||||
sheetConf("StartRow") = 7
|
||||
sheetConf("HeaderRow") = 5
|
||||
sheetConf("CSV_Encoding") = "utf-8"
|
||||
sheetConf("HasHeader") = False
|
||||
sheetConf("ExpectedColumnCount") = 5
|
||||
sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G")
|
||||
sheetConf("AlwaysQuote") = True
|
||||
sheetConf("FilterRow") = 6
|
||||
sheetConf("KeyCol") = 3
|
||||
sheetConf("ValueCols") = Array(4)
|
||||
Set sheetConfDict("Z2") = sheetConf
|
||||
Debug.Print "RefreshSheetDict Z2 ok."
|
||||
|
||||
' Z3
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartCol") = "C"
|
||||
sheetConf("EndCol") = "H"
|
||||
sheetConf("ErrorCol") = "B"
|
||||
sheetConf("StartRow") = 7
|
||||
sheetConf("HeaderRow") = 5
|
||||
sheetConf("CSV_Encoding") = "utf-8"
|
||||
sheetConf("HasHeader") = False
|
||||
sheetConf("ExpectedColumnCount") = 6
|
||||
sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H")
|
||||
sheetConf("AlwaysQuote") = True
|
||||
sheetConf("FilterRow") = 6
|
||||
sheetConf("KeyCol") = 3
|
||||
sheetConf("ValueCols") = Array(4)
|
||||
Set sheetConfDict("Z3") = sheetConf
|
||||
Debug.Print "RefreshSheetDict Z3 ok."
|
||||
|
||||
' Z4
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartCol") = "C"
|
||||
sheetConf("EndCol") = "I"
|
||||
sheetConf("ErrorCol") = "B"
|
||||
sheetConf("StartRow") = 7
|
||||
sheetConf("HeaderRow") = 5
|
||||
sheetConf("CSV_Encoding") = "utf-8"
|
||||
sheetConf("HasHeader") = False
|
||||
sheetConf("ExpectedColumnCount") = 7
|
||||
sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I")
|
||||
sheetConf("AlwaysQuote") = True
|
||||
sheetConf("FilterRow") = 6
|
||||
sheetConf("KeyCol") = 3
|
||||
sheetConf("ValueCols") = Array(4)
|
||||
Set sheetConfDict("Z4") = sheetConf
|
||||
Debug.Print "RefreshSheetDict Z4 ok."
|
||||
|
||||
' T1
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartCol") = "C"
|
||||
sheetConf("EndCol") = "G"
|
||||
sheetConf("ErrorCol") = "B"
|
||||
sheetConf("StartRow") = 7
|
||||
sheetConf("HeaderRow") = 5
|
||||
sheetConf("CSV_Encoding") = "utf-8"
|
||||
sheetConf("HasHeader") = False
|
||||
sheetConf("ExpectedColumnCount") = 5
|
||||
sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G")
|
||||
sheetConf("AlwaysQuote") = True
|
||||
sheetConf("FilterRow") = 6
|
||||
sheetConf("KeyCol") = 3
|
||||
sheetConf("ValueCols") = Array(4)
|
||||
Set sheetConfDict("T1") = sheetConf
|
||||
Debug.Print "RefreshSheetDict T1 ok."
|
||||
|
||||
' T2
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartCol") = "C"
|
||||
sheetConf("EndCol") = "M"
|
||||
sheetConf("ErrorCol") = "B"
|
||||
sheetConf("StartRow") = 7
|
||||
sheetConf("HeaderRow") = 5
|
||||
sheetConf("CSV_Encoding") = "utf-8"
|
||||
sheetConf("HasHeader") = False
|
||||
sheetConf("ExpectedColumnCount") = 11
|
||||
sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M")
|
||||
sheetConf("AlwaysQuote") = True
|
||||
sheetConf("FilterRow") = 6
|
||||
sheetConf("KeyCol") = 3
|
||||
sheetConf("ValueCols") = Array(4, 6, 8, 9, 10, 11, 12, 13)
|
||||
Set sheetConfDict("T2") = sheetConf
|
||||
Debug.Print "RefreshSheetDict T2 ok."
|
||||
|
||||
' T3
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartCol") = "C"
|
||||
sheetConf("EndCol") = "I"
|
||||
sheetConf("ErrorCol") = "B"
|
||||
sheetConf("StartRow") = 7
|
||||
sheetConf("HeaderRow") = 5
|
||||
sheetConf("CSV_Encoding") = "utf-8"
|
||||
sheetConf("HasHeader") = False
|
||||
sheetConf("ExpectedColumnCount") = 7
|
||||
sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I")
|
||||
sheetConf("AlwaysQuote") = True
|
||||
sheetConf("FilterRow") = 6
|
||||
sheetConf("KeyCol") = 3
|
||||
sheetConf("ValueCols") = Array(4, 8, 9)
|
||||
Set sheetConfDict("T3") = sheetConf
|
||||
Debug.Print "RefreshSheetDict T3 ok."
|
||||
|
||||
' O1
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartCol") = "C"
|
||||
sheetConf("EndCol") = "F"
|
||||
sheetConf("ErrorCol") = ""
|
||||
sheetConf("StartRow") = 6
|
||||
sheetConf("HeaderRow") = ""
|
||||
sheetConf("CSV_Encoding") = "utf-8"
|
||||
sheetConf("HasHeader") = False
|
||||
sheetConf("ExpectedColumnCount") = 4
|
||||
sheetConf("HeaderColumns") = Array("C", "D", "E", "F")
|
||||
sheetConf("AlwaysQuote") = True
|
||||
sheetConf("FilterRow") = 5
|
||||
Set sheetConfDict("O1") = sheetConf
|
||||
Debug.Print "RefreshSheetDict O1 ok."
|
||||
|
||||
' O2
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartCol") = "C"
|
||||
sheetConf("EndCol") = "O"
|
||||
sheetConf("ErrorCol") = ""
|
||||
sheetConf("StartRow") = 6
|
||||
sheetConf("HeaderRow") = ""
|
||||
sheetConf("CSV_Encoding") = "utf-8"
|
||||
sheetConf("HasHeader") = False
|
||||
sheetConf("ExpectedColumnCount") = 13
|
||||
sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O")
|
||||
sheetConf("AlwaysQuote") = True
|
||||
sheetConf("FilterRow") = 5
|
||||
sheetConf("KeyCol") = 3
|
||||
sheetConf("ValueCols") = Array(4)
|
||||
Set sheetConfDict("O2") = sheetConf
|
||||
Debug.Print "RefreshSheetDict O2 ok."
|
||||
|
||||
' Enum
|
||||
Set sheetConf = Nothing
|
||||
sheetConfDict("Enum") = Array("tokubetuList", "kenshuList", "oufukuList", "koutaiList", "higaitouList", "errorList")
|
||||
Debug.Print "RefreshSheetDict Enum ok."
|
||||
|
||||
' tokubetuList
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartRow") = 3
|
||||
sheetConf("KeyCol") = 1
|
||||
sheetConf("ValueCols") = Array(1)
|
||||
Set sheetConfDict("tokubetuList") = sheetConf
|
||||
Debug.Print "RefreshSheetDict tokubetuList ok."
|
||||
|
||||
' kenshuList
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartRow") = 3
|
||||
sheetConf("KeyCol") = 3
|
||||
sheetConf("ValueCols") = Array(4)
|
||||
Set sheetConfDict("kenshuList") = sheetConf
|
||||
Debug.Print "RefreshSheetDict kenshuList ok."
|
||||
|
||||
' oufukuList
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartRow") = 3
|
||||
sheetConf("KeyCol") = 6
|
||||
sheetConf("ValueCols") = Array(7)
|
||||
Set sheetConfDict("oufukuList") = sheetConf
|
||||
Debug.Print "RefreshSheetDict oufukuList ok."
|
||||
|
||||
' koutaiList
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartRow") = 3
|
||||
sheetConf("KeyCol") = 9
|
||||
sheetConf("ValueCols") = Array(10)
|
||||
Set sheetConfDict("koutaiList") = sheetConf
|
||||
Debug.Print "RefreshSheetDict koutaiList ok."
|
||||
|
||||
' higaitouList
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartRow") = 3
|
||||
sheetConf("KeyCol") = 12
|
||||
sheetConf("ValueCols") = Array(13)
|
||||
Set sheetConfDict("higaitouList") = sheetConf
|
||||
Debug.Print "RefreshSheetDict higaitouList ok."
|
||||
|
||||
' errorList
|
||||
Set sheetConf = CreateObject("Scripting.Dictionary")
|
||||
sheetConf("StartRow") = 3
|
||||
sheetConf("KeyCol") = 15
|
||||
sheetConf("ValueCols") = Array(16)
|
||||
Set sheetConfDict("errorList") = sheetConf
|
||||
Debug.Print "RefreshSheetDict errorList ok."
|
||||
|
||||
Debug.Print "RefreshSheetDict end."
|
||||
End Sub
|
||||
|
||||
Public Function GetSheetConfig() As Object
|
||||
If sheetConfDict Is Nothing Then Call RefreshSheetDict
|
||||
Set GetSheetConfig = sheetConfDict
|
||||
End Function
|
||||
|
||||
Public Function RefreshAllCache() As Boolean
|
||||
' refresh
|
||||
Dim refreshCacheNames As Variant
|
||||
refreshCacheNames = Array("Z1", "Z2", "Z3", "Z4", "T1", "T2", "T3", "M1", "M1KukanDCache", "M2", "O1","O2", _
|
||||
"tokubetuList", "kenshuList", "oufukuList", "koutaiList", "higaitouList", "errorList")
|
||||
Dim refreshCacheName As Variant
|
||||
For Each refreshCacheName In refreshCacheNames
|
||||
Call RefreshCache(refreshCacheName)
|
||||
Next refreshCacheName
|
||||
|
||||
RefreshAllCache = True
|
||||
End Function
|
||||
161
src/sh/tuk/module/Common_Selector.bas
Normal file
161
src/sh/tuk/module/Common_Selector.bas
Normal file
@@ -0,0 +1,161 @@
|
||||
Attribute VB_Name = "Common_Selector"
|
||||
Option Explicit
|
||||
' ============================================================
|
||||
' Module Name: Build_Select
|
||||
' Module Desc: Commuter allowance editing sheet (no CSV import)
|
||||
' Module Methods:
|
||||
' - Tukin_ValidateRow
|
||||
' - FillTransportFromM1KukanD
|
||||
' - FillDepartureFromM1KukanD
|
||||
' - FillArrivalFromM1KukanD
|
||||
' - FillKukanFromM1
|
||||
' - FillKanshuFromM2
|
||||
' - FillCodeFromM2
|
||||
' - FillAddressFromO1
|
||||
' - FillZ1Dropdown
|
||||
' ============================================================
|
||||
|
||||
' Create transport (T) dropdown from Z1 cache
|
||||
Public Function BuildTransportList()
|
||||
Dim z1Cache As Object: Set z1Cache = GetCache("Z1")
|
||||
|
||||
Dim dropdownList As String
|
||||
Dim key As Variant
|
||||
For Each key In z1Cache.Keys
|
||||
Dim displayText As String
|
||||
displayText = MakeSelect(key, z1Cache(key)(0))
|
||||
If dropdownList = "" Then
|
||||
dropdownList = displayText
|
||||
Else
|
||||
dropdownList = dropdownList & "," & displayText
|
||||
End If
|
||||
Next key
|
||||
|
||||
BuildTransportList = dropdownList
|
||||
End Function
|
||||
|
||||
' Create todoke (G) dropdown
|
||||
Public Function BuildTodokeList()
|
||||
Dim z4Cache As Object: Set z4Cache = GetCache("Z4")
|
||||
|
||||
Dim dropdownList As String
|
||||
Dim key As Variant
|
||||
For Each key In z4Cache.Keys
|
||||
Dim displayText As String
|
||||
displayText = MakeSelect(key, z4Cache(key)(0))
|
||||
If dropdownList = "" Then
|
||||
dropdownList = displayText
|
||||
Else
|
||||
dropdownList = dropdownList & "," & displayText
|
||||
End If
|
||||
Next key
|
||||
BuildTodokeList = dropdownList
|
||||
End Function
|
||||
|
||||
' Create oufuku (M) dropdown
|
||||
Public Function BuildOufukuList()
|
||||
Dim oufukuList As Object: Set oufukuList = GetCache("oufukuList")
|
||||
|
||||
Dim dropdownList As String
|
||||
Dim key As Variant
|
||||
For Each key In oufukuList.Keys
|
||||
Dim displayText As String
|
||||
displayText = MakeSelect(key, oufukuList(key)(0))
|
||||
If dropdownList = "" Then
|
||||
dropdownList = displayText
|
||||
Else
|
||||
dropdownList = dropdownList & "," & displayText
|
||||
End If
|
||||
Next key
|
||||
BuildOufukuList = dropdownList
|
||||
End Function
|
||||
|
||||
' Create Koutai (N) dropdown
|
||||
Public Function BuildKoutaiList()
|
||||
Dim koutaiList As Object: Set koutaiList = GetCache("koutaiList")
|
||||
|
||||
Dim dropdownList As String
|
||||
Dim key As Variant
|
||||
For Each key In koutaiList.Keys
|
||||
Dim displayText As String
|
||||
displayText = MakeSelect(key, koutaiList(key)(0))
|
||||
If dropdownList = "" Then
|
||||
dropdownList = displayText
|
||||
Else
|
||||
dropdownList = dropdownList & "," & displayText
|
||||
End If
|
||||
Next key
|
||||
BuildKoutaiList = dropdownList
|
||||
End Function
|
||||
|
||||
' Create Kettei (AU) dropdown
|
||||
Public Function BuildKetteiList()
|
||||
Dim z2Cache As Object: Set z2Cache = GetCache("Z2")
|
||||
|
||||
Dim dropdownList As String
|
||||
Dim key As Variant
|
||||
For Each key In z2Cache.Keys
|
||||
Dim displayText As String
|
||||
displayText = MakeSelect(key, z2Cache(key)(0))
|
||||
If dropdownList = "" Then
|
||||
dropdownList = displayText
|
||||
Else
|
||||
dropdownList = dropdownList & "," & displayText
|
||||
End If
|
||||
Next key
|
||||
BuildKetteiList = dropdownList
|
||||
End Function
|
||||
|
||||
' Create Higaitou (AW) dropdown
|
||||
Public Function BuildHigaitouList()
|
||||
Dim higaitouList As Object: Set higaitouList = GetCache("higaitouList")
|
||||
|
||||
Dim dropdownList As String
|
||||
Dim key As Variant
|
||||
For Each key In higaitouList.Keys
|
||||
Dim displayText As String
|
||||
displayText = MakeSelect(key, higaitouList(key)(0))
|
||||
If dropdownList = "" Then
|
||||
dropdownList = displayText
|
||||
Else
|
||||
dropdownList = dropdownList & "," & displayText
|
||||
End If
|
||||
Next key
|
||||
BuildHigaitouList = dropdownList
|
||||
End Function
|
||||
|
||||
' Create MonthAmountKbn (AX) dropdown
|
||||
Public Function BuildMonthAmountKbnList()
|
||||
Dim z3Cache As Object: Set z3Cache = GetCache("Z3")
|
||||
|
||||
Dim dropdownList As String
|
||||
Dim key As Variant
|
||||
For Each key In z3Cache.Keys
|
||||
Dim displayText As String
|
||||
displayText = MakeSelect(key, z3Cache(key)(0))
|
||||
If dropdownList = "" Then
|
||||
dropdownList = displayText
|
||||
Else
|
||||
dropdownList = dropdownList & "," & displayText
|
||||
End If
|
||||
Next key
|
||||
BuildMonthAmountKbnList = dropdownList
|
||||
End Function
|
||||
|
||||
' Create Kanshoku (BC) dropdown
|
||||
Public Function BuildKanshokuList()
|
||||
Dim o2Cache As Object: Set o2Cache = GetCache("O2")
|
||||
|
||||
Dim dropdownList As String
|
||||
Dim key As Variant
|
||||
For Each key In o2Cache.Keys
|
||||
Dim displayText As String
|
||||
displayText = MakeSelect(key, o2Cache(key)(0))
|
||||
If dropdownList = "" Then
|
||||
dropdownList = displayText
|
||||
Else
|
||||
dropdownList = dropdownList & "," & displayText
|
||||
End If
|
||||
Next key
|
||||
BuildKanshokuList = dropdownList
|
||||
End Function
|
||||
846
src/sh/tuk/sheet/C1.cls
Normal file
846
src/sh/tuk/sheet/C1.cls
Normal file
@@ -0,0 +1,846 @@
|
||||
' ============================================================
|
||||
' Module Name: Tukin_C1
|
||||
' Module Desc: Commuter allowance editing sheet (no CSV import)
|
||||
' Module Methods:
|
||||
' - Tukin_ValidateRow
|
||||
' - FillTransportFromM1KukanD
|
||||
' - FillDepartureFromM1KukanD
|
||||
' - FillArrivalFromM1KukanD
|
||||
' - FillKukanFromM1
|
||||
' - FillKanshuFromM2
|
||||
' - FillCodeFromM2
|
||||
' - CreateAddress1Dropdown
|
||||
' - FillZ1Dropdown
|
||||
' ============================================================
|
||||
' ====== (Tukin_C1) =======
|
||||
' Commuter allowance editing sheet
|
||||
' No CSV import - direct editing only
|
||||
' ============================================================
|
||||
' Column arrays for 4 kukan sections
|
||||
' ============================================================
|
||||
Const CSHAINNO_COL As String = "C"
|
||||
Const ADDRESS1_COL As String = "I"
|
||||
Const ADDRESS2_COL As String = "J"
|
||||
|
||||
Private Function KUKAN_CODE_COLS() As Variant
|
||||
KUKAN_CODE_COLS = Array(19, 26, 33, 40) ' S, Z, AG, AN
|
||||
End Function
|
||||
|
||||
Private Function KUKAN_TRANSPORT_COLS() As Variant
|
||||
KUKAN_TRANSPORT_COLS = Array(20, 27, 34, 41) ' T, AA, AH, AO
|
||||
End Function
|
||||
|
||||
Private Function KUKAN_STATION_COLS() As Variant
|
||||
KUKAN_STATION_COLS = Array(21, 28, 35, 42) ' U, AB, AI, AP
|
||||
End Function
|
||||
|
||||
Private Function KUKAN_ARRIVAL_COLS() As Variant
|
||||
KUKAN_ARRIVAL_COLS = Array(22, 29, 36, 43) ' V, AC, AJ, AQ
|
||||
End Function
|
||||
|
||||
Private Function KUKAN_TICKET_COLS() As Variant
|
||||
KUKAN_TICKET_COLS = Array(23, 30, 37, 44) ' W, AD, AK, AR
|
||||
End Function
|
||||
|
||||
Private Function KUKAN_CODE2_COLS() As Variant
|
||||
KUKAN_CODE2_COLS = Array(24, 31, 38, 45) ' X, AE, AL, AS
|
||||
End Function
|
||||
|
||||
Private Function KUKAN_START_DAY_COLS() As Variant
|
||||
KUKAN_START_DAY_COLS = Array(25, 32, 39, 46) ' Y, AF, AM, AT
|
||||
End Function
|
||||
|
||||
Private Function DATE_COLS() As Variant
|
||||
DATE_COLS = Array(4, 5, 6, 25, 32, 39, 46, 51, 54) ' D, E, F, Y, AF, AM, AT, AY, BB
|
||||
End Function
|
||||
|
||||
Private Function NUMBER_COLS() As Variant
|
||||
NUMBER_COLS = Array("L", "P", "Q", "R")
|
||||
End Function
|
||||
|
||||
' ============================================================
|
||||
' Helper: Get index by value, return -1 if not found
|
||||
' ============================================================
|
||||
Private Function GetIdx(val As Long, arr As Variant) As Long
|
||||
Dim i As Long
|
||||
For i = LBound(arr) To UBound(arr)
|
||||
If arr(i) = val Then
|
||||
GetIdx = i
|
||||
Exit Function
|
||||
End If
|
||||
Next i
|
||||
GetIdx = -1
|
||||
End Function
|
||||
|
||||
' ============================================================
|
||||
' Event Handlers
|
||||
' ============================================================
|
||||
Private Sub Worksheet_Change(ByVal Target As Range)
|
||||
|
||||
Dim HasHeaderEdit As Boolean: HasHeaderEdit = CheckHeaderEdit(Me, Target)
|
||||
If HasHeaderEdit = True Then Exit Sub
|
||||
|
||||
Dim watchArea As Range
|
||||
With Me
|
||||
Set watchArea = Union( _
|
||||
.Columns("C"), _
|
||||
.Columns("D"), _
|
||||
.Columns("E"), _
|
||||
.Columns("F"), _
|
||||
.Columns("G"), _
|
||||
.Columns("I"), _
|
||||
.Columns("S:W"), _
|
||||
.Columns("Z:AD"), _
|
||||
.Columns("AG:AK"), _
|
||||
.Columns("AN:AR"), _
|
||||
.Columns("BB") _
|
||||
)
|
||||
End With
|
||||
Dim intersectRng As Range: Set intersectRng = Application.Intersect(Target, watchArea)
|
||||
If intersectRng Is Nothing Then Exit Sub
|
||||
|
||||
If Target.Row < 8 Then Exit Sub
|
||||
Dim idx As Long
|
||||
|
||||
Application.EnableEvents = False
|
||||
On Error GoTo Finally
|
||||
|
||||
' === 3. rebuild dropdown list ===
|
||||
Call RebuildDropdownsForTarget(Target)
|
||||
|
||||
' === Column C changes ===
|
||||
If Target.Column = 3 Then
|
||||
Dim cell As Range
|
||||
For Each cell In Target
|
||||
Dim cshainno As String: cshainno = Trim(cell.Value)
|
||||
If cshainno = "" Then
|
||||
Call ClearRowData(cell.Row)
|
||||
Else
|
||||
Call CreateAddress1Dropdown(cell.Row, cshainno)
|
||||
End If
|
||||
Next
|
||||
End If
|
||||
|
||||
' auto fill G column [todoke biko]
|
||||
If Target.Column = 7 Then
|
||||
Dim cellG As Range
|
||||
For Each cellG In Target
|
||||
Dim todoke As String: todoke = Trim(cellG.Value)
|
||||
If todoke <> "" Then
|
||||
Dim z4Cache As Object: Set z4Cache = GetCache("Z4")
|
||||
Dim todokeCde As String: todokeCde = GetCode(todoke)
|
||||
If z4Cache.Exists(todokeCde) Then
|
||||
Dim cellH As Range: Set cellH = Me.Cells(cellG.Row, 8)
|
||||
cellH.Value = z4Cache(todokeCde)(0)
|
||||
End If
|
||||
End If
|
||||
Next
|
||||
End If
|
||||
|
||||
' === Column I changes ===
|
||||
If Target.Column = 9 Then
|
||||
Dim cellI As Range
|
||||
For Each cellI In Target
|
||||
Call CreateAddress2Dropdown(cellI.Row)
|
||||
Next
|
||||
End If
|
||||
|
||||
' === Date columns changes ===
|
||||
idx = GetIdx(Target.Column, DATE_COLS)
|
||||
If idx >= 0 Then
|
||||
Dim cellDate As Range
|
||||
For Each cellDate In Target
|
||||
If Trim(cellDate.Value) <> "" Then
|
||||
Dim formattedDate As String: formattedDate = FormatDateInput(cellDate.Value)
|
||||
cellDate.Value = FormatDateInput(formattedDate)
|
||||
If cellDate.Column = 5 Then
|
||||
Dim fCell As Range: Set fCell = Me.Cells(cellDate.Row, 6)
|
||||
If Trim(fCell.Value) = "" Then
|
||||
fCell.Value = formattedDate
|
||||
End If
|
||||
End If
|
||||
End If
|
||||
Next
|
||||
End If
|
||||
|
||||
' === Transport column changes (T, AA, AH, AO) ===
|
||||
idx = GetIdx(Target.Column, KUKAN_TRANSPORT_COLS)
|
||||
If idx >= 0 Then
|
||||
Dim cellT As Range
|
||||
For Each cellT In Target
|
||||
Me.Cells(cellT.Row, KUKAN_STATION_COLS(idx)).ClearContents
|
||||
Me.Cells(cellT.Row, KUKAN_ARRIVAL_COLS(idx)).ClearContents
|
||||
If Trim(cellT.Value) <> "" Then
|
||||
Call CreateFromStationDropdown(cellT.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx))
|
||||
End If
|
||||
Next
|
||||
End If
|
||||
|
||||
' === Station column changes (U, AB, AI, AP) ===
|
||||
idx = GetIdx(Target.Column, KUKAN_STATION_COLS)
|
||||
If idx >= 0 Then
|
||||
Dim cellU As Range
|
||||
For Each cellU In Target
|
||||
' Clear arrival value first
|
||||
Me.Cells(cellU.Row, KUKAN_ARRIVAL_COLS(idx)).ClearContents
|
||||
If Trim(cellU.Value) <> "" Then
|
||||
Call CreateToStationDropdown(cellU.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx), KUKAN_ARRIVAL_COLS(idx))
|
||||
End If
|
||||
Next
|
||||
End If
|
||||
|
||||
' === Arrival column changes (V, AC, AJ, AQ) ===
|
||||
idx = GetIdx(Target.Column, KUKAN_ARRIVAL_COLS)
|
||||
If idx >= 0 Then
|
||||
Dim cellV As Range
|
||||
For Each cellV In Target
|
||||
If Trim(cellV.Value) <> "" Then
|
||||
' Reverse lookup: find kukan code by transport + from + to
|
||||
Dim foundCode As String
|
||||
foundCode = FindKukanCodeByStation(cellV.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx), KUKAN_ARRIVAL_COLS(idx))
|
||||
If foundCode <> "" Then
|
||||
Me.Cells(cellV.Row, KUKAN_CODE_COLS(idx)).Value = foundCode
|
||||
Call CreateKenshuDropdown(cellV.Row, idx, foundCode)
|
||||
End If
|
||||
End If
|
||||
Next
|
||||
End If
|
||||
|
||||
' === Kukan code column changes (S, Z, AG, AN) ===
|
||||
idx = GetIdx(Target.Column, KUKAN_CODE_COLS)
|
||||
If idx >= 0 Then
|
||||
Dim cellK As Range
|
||||
For Each cellK In Target
|
||||
Call FillKukanFromM1(cellK.Row, idx)
|
||||
Next
|
||||
End If
|
||||
|
||||
' === Ticket column changes (W, AD, AK, AR) ===
|
||||
idx = GetIdx(Target.Column, KUKAN_TICKET_COLS)
|
||||
If idx >= 0 Then
|
||||
Dim cellTi As Range
|
||||
For Each cellTi In Target
|
||||
' Clear old code first
|
||||
Dim code2Col As Long: code2Col = KUKAN_CODE2_COLS(idx)
|
||||
Me.Cells(cellTi.Row, code2Col).ClearContents
|
||||
Me.Cells(cellTi.Row, code2Col).Validation.Delete
|
||||
Call CreateM2CodeDropdown(cellTi.Row, KUKAN_CODE_COLS(idx), KUKAN_TICKET_COLS(idx), code2Col)
|
||||
Next
|
||||
End If
|
||||
|
||||
Finally:
|
||||
Application.EnableEvents = True '
|
||||
End Sub
|
||||
|
||||
Private Sub RebuildDropdownsForTarget(ByVal Target As Range)
|
||||
If Target Is Nothing Then Exit Sub
|
||||
|
||||
Dim cell As Range
|
||||
Dim processedRows As Object
|
||||
Set processedRows = CreateObject("Scripting.Dictionary")
|
||||
|
||||
For Each cell In Target
|
||||
Dim r As Long
|
||||
r = cell.Row
|
||||
|
||||
If Not processedRows.Exists(r) Then
|
||||
processedRows(r) = True
|
||||
|
||||
Dim colLetter As String
|
||||
colLetter = Split(Me.Cells(1, cell.Column).Address(True, False), "$")(0)
|
||||
|
||||
Dim dropdowns As Variant
|
||||
dropdowns = Array( _
|
||||
Array("T", "BuildTransportList"), _
|
||||
Array("AA", "BuildTransportList"), _
|
||||
Array("AH", "BuildTransportList"), _
|
||||
Array("AO", "BuildTransportList"), _
|
||||
Array("G", "BuildTodokeList"), _
|
||||
Array("M", "BuildOufukuList"), _
|
||||
Array("N", "BuildKoutaiList"), _
|
||||
Array("AU", "BuildKetteiList"), _
|
||||
Array("AW", "BuildHigaitouList"), _
|
||||
Array("AX", "BuildMonthAmountKbnList"), _
|
||||
Array("BC", "BuildKanshokuList") _
|
||||
)
|
||||
|
||||
Dim i As Long
|
||||
For i = LBound(dropdowns) To UBound(dropdowns)
|
||||
If colLetter <> dropdowns(i)(0) Then
|
||||
With Me.Cells(r, dropdowns(i)(0)).Validation
|
||||
.Delete
|
||||
.Add Type:=xlValidateList, Formula1:=Application.Run(dropdowns(i)(1))
|
||||
.IgnoreBlank = True
|
||||
.InCellDropdown = True
|
||||
End With
|
||||
End If
|
||||
Next i
|
||||
|
||||
End If
|
||||
NextCell:
|
||||
Next cell
|
||||
End Sub
|
||||
|
||||
' Fill kukan info from M1 cache (key: kukan code, value: 7 elements)
|
||||
Private Sub FillKukanFromM1(ByVal rowNum As Long, ByVal idx As Long)
|
||||
Dim m1Cache As Object: Set m1Cache = GetCache("M1")
|
||||
|
||||
Dim codeCol As Long: codeCol = KUKAN_CODE_COLS(idx)
|
||||
Dim transportCol As Long: transportCol = KUKAN_TRANSPORT_COLS(idx)
|
||||
Dim stationCol As Long: stationCol = KUKAN_STATION_COLS(idx)
|
||||
Dim arrivalCol As Long: arrivalCol = KUKAN_ARRIVAL_COLS(idx)
|
||||
Dim ticketCol As Long: ticketCol = KUKAN_TICKET_COLS(idx)
|
||||
Dim code2Col As Long: code2Col = KUKAN_CODE2_COLS(idx)
|
||||
Dim startDayCol As Long: startDayCol = KUKAN_START_DAY_COLS(idx)
|
||||
|
||||
Dim code As String: code = Trim(Me.Cells(rowNum, codeCol).Value)
|
||||
|
||||
If code <> "" And m1Cache.Exists(code) Then
|
||||
Dim vals As Variant: vals = m1Cache(code)
|
||||
Me.Cells(rowNum, transportCol).Value = MakeSelect(vals(1), vals(2))
|
||||
Me.Cells(rowNum, stationCol).Value = Trim(vals(3))
|
||||
Me.Cells(rowNum, arrivalCol).Value = Trim(vals(4))
|
||||
Call CreateKenshuDropdown(rowNum, idx, code)
|
||||
Else
|
||||
Me.Cells(rowNum, transportCol).ClearContents
|
||||
Me.Cells(rowNum, stationCol).ClearContents
|
||||
Me.Cells(rowNum, arrivalCol).ClearContents
|
||||
Me.Cells(rowNum, startDayCol).ClearContents
|
||||
|
||||
Call ClearKukanValidation(rowNum, stationCol)
|
||||
Call ClearKukanValidation(rowNum, arrivalCol)
|
||||
Call ClearKukanValidation(rowNum, code2Col)
|
||||
End If
|
||||
|
||||
Me.Cells(rowNum, ticketCol).ClearContents
|
||||
Me.Cells(rowNum, code2Col).ClearContents
|
||||
End Sub
|
||||
|
||||
' triggered by c clomun cshainno input
|
||||
' when cshainno does not exist in o1, clear dropdownList and value
|
||||
' when cshainno exist in o1, create dropdownList and value
|
||||
Private Sub CreateAddress1Dropdown(ByVal rowNum As Long, ByVal cshainno As String)
|
||||
Dim o1Cache As Object: Set o1Cache = GetCache("O1")
|
||||
Me.Range("I" & rowNum).Validation.Delete
|
||||
Me.Range("I" & rowNum).Value = ""
|
||||
Me.Range("J" & rowNum).Validation.Delete
|
||||
Me.Range("J" & rowNum).Value = ""
|
||||
' Build dropdown list from O1 cache: get all E values for the C
|
||||
Dim dropdownList As String
|
||||
If o1Cache.Exists(cshainno) Then
|
||||
Dim innerDict As Object
|
||||
Set innerDict = o1Cache(cshainno)
|
||||
Dim eKey As Variant
|
||||
For Each eKey In innerDict.Keys
|
||||
If dropdownList = "" Then
|
||||
dropdownList = eKey
|
||||
Else
|
||||
dropdownList = dropdownList & "," & eKey
|
||||
End If
|
||||
Next eKey
|
||||
End If
|
||||
|
||||
' Create dropdown for I column address1
|
||||
If dropdownList <> "" Then
|
||||
With Me.Range("I" & rowNum).Validation
|
||||
.Delete
|
||||
.Add Type:=xlValidateList, Formula1:=dropdownList
|
||||
.IgnoreBlank = True
|
||||
.InCellDropdown = True
|
||||
.InputTitle = ""
|
||||
.InputMessage = ""
|
||||
End With
|
||||
End If
|
||||
End Sub
|
||||
|
||||
' triggered by address1 select O1 cache
|
||||
Private Sub CreateAddress2Dropdown(ByVal rowNum As Long)
|
||||
' Clear address2 contents
|
||||
Me.Range(ADDRESS2_COL & rowNum).Validation.Delete
|
||||
Me.Range(ADDRESS2_COL & rowNum).Value = ""
|
||||
' obtain cshainno, address1, o1Cache
|
||||
Dim o1Cache As Object: Set o1Cache = GetCache("O1")
|
||||
Dim cshainno As String: cshainno = Trim(Me.Cells(rowNum, CSHAINNO_COL).Value)
|
||||
Dim address1 As String: address1 = Trim(Me.Cells(rowNum, ADDRESS1_COL).Value)
|
||||
If cshainno = "" OR address1 = "" Then
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' Build dropdown list from O1 cache
|
||||
Dim dropdownList As String
|
||||
If o1Cache.Exists(cshainno) Then
|
||||
Dim innerDict As Object
|
||||
Set innerDict = o1Cache(cshainno)
|
||||
|
||||
If innerDict.Exists(address1) Then
|
||||
Dim addr2Dict As Object
|
||||
Set addr2Dict = innerDict(address1)
|
||||
|
||||
Dim addr2Key As Variant
|
||||
For Each addr2Key In addr2Dict.Keys
|
||||
If dropdownList = "" Then
|
||||
dropdownList = addr2Key
|
||||
Else
|
||||
dropdownList = dropdownList & "," & addr2Key
|
||||
End If
|
||||
Next addr2Key
|
||||
End If
|
||||
End If
|
||||
|
||||
' Create dropdown for J column
|
||||
If dropdownList <> "" Then
|
||||
With Me.Range("J" & rowNum).Validation
|
||||
.Delete
|
||||
.Add Type:=xlValidateList, Formula1:=dropdownList
|
||||
.IgnoreBlank = True
|
||||
.InCellDropdown = True
|
||||
.InputTitle = ""
|
||||
.InputMessage = ""
|
||||
End With
|
||||
End If
|
||||
End Sub
|
||||
|
||||
' Create station from dropdown from M1_KukanD cache
|
||||
Private Sub CreateFromStationDropdown(ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationCol As Long)
|
||||
Dim m1KukanDCache As Object: Set m1KukanDCache = GetCache("M1KukanDCache")
|
||||
|
||||
Dim transport As String: transport = GetCode(Me.Cells(rowNum, transportCol).Value)
|
||||
If transport = "" Then Exit Sub
|
||||
|
||||
' Build dropdown list from M1_KukanD cache: get all F values for the transport (D)
|
||||
Dim dropdownList As String
|
||||
If m1KukanDCache.Exists(transport) Then
|
||||
Dim innerDict As Object: Set innerDict = m1KukanDCache(transport)
|
||||
Dim fValue As Variant
|
||||
For Each fValue In innerDict.Keys
|
||||
If dropdownList = "" Then
|
||||
dropdownList = fValue
|
||||
Else
|
||||
dropdownList = dropdownList & "," & fValue
|
||||
End If
|
||||
Next fValue
|
||||
End If
|
||||
|
||||
If dropdownList <> "" Then
|
||||
With Me.Cells(rowNum, stationCol).Validation
|
||||
.Delete
|
||||
.Add Type:=xlValidateList, Formula1:=dropdownList
|
||||
.IgnoreBlank = True
|
||||
.InCellDropdown = True
|
||||
End With
|
||||
End If
|
||||
End Sub
|
||||
|
||||
' Create Kenshu dropdown from
|
||||
' Structure: { D: { F: [G] } }
|
||||
Private Sub CreateKenshuDropdown(ByVal rowNum As Long, ByVal idx As Long, ByVal kukanCode As String)
|
||||
Dim kenshuList As Object: Set kenshuList = GetCache("kenshuList")
|
||||
Dim m2Cache As Object: Set m2Cache = GetCache("M2")
|
||||
Dim ticketCol As Long: ticketCol = KUKAN_TICKET_COLS(idx)
|
||||
|
||||
Me.Cells(rowNum, ticketCol).ClearContents
|
||||
Call ClearKukanValidation(rowNum, ticketCol)
|
||||
|
||||
Dim kanshuDict As Object
|
||||
if m2Cache.Exists(kukanCode) Then
|
||||
Set kanshuDict = m2Cache(kukanCode)
|
||||
End If
|
||||
|
||||
Dim dropdownList As String: dropdownList = MakeSelect("0", kenshuList("0")(0))
|
||||
If Not kanshuDict Is Nothing Then
|
||||
Dim key As Variant
|
||||
For Each key In kenshuList.Keys
|
||||
If kanshuDict.Exists(key) Then
|
||||
dropdownList = dropdownList & "," & MakeSelect(key, kenshuList(key)(0))
|
||||
End If
|
||||
Next key
|
||||
End If
|
||||
|
||||
With Me.Cells(rowNum, ticketCol).Validation
|
||||
.Delete
|
||||
.Add Type:=xlValidateList, Formula1:=dropdownList
|
||||
.IgnoreBlank = True
|
||||
.InCellDropdown = True
|
||||
End With
|
||||
End Sub
|
||||
|
||||
' Create destination dropdown from M1_KukanD cache
|
||||
' Structure: { D: { F: [G] } }
|
||||
Private Sub CreateToStationDropdown(ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationFromCol As Long, ByVal stationToCol As Long)
|
||||
Dim m1KukanDCache As Object: Set m1KukanDCache = GetCache("M1KukanDCache")
|
||||
|
||||
Dim transport As String: transport = GetCode(Me.Cells(rowNum, transportCol).Value)
|
||||
Dim stationFrom As String: stationFrom = GetCode(Me.Cells(rowNum, stationFromCol).Value)
|
||||
If transport = "" Or stationFrom = "" Then Exit Sub
|
||||
|
||||
' Build dropdown list from M1_KukanD cache
|
||||
Dim dropdownList As String
|
||||
If m1KukanDCache.Exists(transport) Then
|
||||
Dim innerDict As Object: Set innerDict = m1KukanDCache(transport)
|
||||
If innerDict.Exists(stationFrom) Then
|
||||
Dim arr As Object: Set arr = innerDict(stationFrom)
|
||||
Dim gValue As Variant
|
||||
For Each gValue In arr.Keys
|
||||
If dropdownList = "" Then
|
||||
dropdownList = gValue
|
||||
Else
|
||||
dropdownList = dropdownList & "," & gValue
|
||||
End If
|
||||
Next gValue
|
||||
End If
|
||||
End If
|
||||
|
||||
If dropdownList <> "" Then
|
||||
With Me.Cells(rowNum, stationToCol).Validation
|
||||
.Delete
|
||||
.Add Type:=xlValidateList, Formula1:=dropdownList
|
||||
.IgnoreBlank = True
|
||||
.InCellDropdown = True
|
||||
End With
|
||||
End If
|
||||
End Sub
|
||||
|
||||
' Find kukan code by transport + station_from + station_to (reverse lookup)
|
||||
Private Function FindKukanCodeByStation(ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationFromCol As Long, ByVal stationToCol As Long) As String
|
||||
Dim m1Cache As Object: Set m1Cache = GetCache("M1")
|
||||
|
||||
Dim transportKbn As String: transportKbn = GetCode(Trim(Me.Cells(rowNum, transportCol).Value))
|
||||
Dim stationFrom As String: stationFrom = Trim(Me.Cells(rowNum, stationFromCol).Value)
|
||||
Dim stationTo As String: stationTo = Trim(Me.Cells(rowNum, stationToCol).Value)
|
||||
|
||||
If transportKbn = "" Or stationFrom = "" Or stationTo = "" Then
|
||||
FindKukanCodeByStation = ""
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim code As Variant
|
||||
For Each code In m1Cache.Keys
|
||||
Dim vals As Variant: vals = m1Cache(code)
|
||||
' vals(1) = D列, vals(3) = F列, vals(4) = G列
|
||||
If vals(1) = transportKbn And vals(3) = stationFrom And vals(4) = stationTo Then
|
||||
FindKukanCodeByStation = code
|
||||
Exit Function
|
||||
End If
|
||||
Next code
|
||||
|
||||
FindKukanCodeByStation = ""
|
||||
End Function
|
||||
|
||||
' Clear validation for kukan columns
|
||||
Private Sub ClearKukanValidation(ByVal rowNum As Long, ByVal col As Long)
|
||||
Me.Cells(rowNum, col).Validation.Delete
|
||||
End Sub
|
||||
|
||||
' Create dropdown from M2 cache: get code (J) list for kukanCode + kanshu
|
||||
Private Sub CreateM2CodeDropdown(ByVal rowNum As Long, ByVal kukanCodeCol As Long, ByVal kanshuCol As Long, ByVal codeCol As Long)
|
||||
Dim m2Cache As Object: Set m2Cache = GetCache("M2")
|
||||
|
||||
Dim kukanCode As String: kukanCode = Trim(Me.Cells(rowNum, kukanCodeCol).Value)
|
||||
Dim kanshuStr As String: kanshuStr = Trim(Me.Cells(rowNum, kanshuCol).Value)
|
||||
If kukanCode = "" Or kanshuStr = "" Then Exit Sub
|
||||
|
||||
' Build dropdown list: get all code for kukanCode + kanshuStr
|
||||
Dim dropdownList As String
|
||||
If m2Cache.Exists(kukanCode) Then
|
||||
Dim innerDict As Object: Set innerDict = m2Cache(kukanCode)
|
||||
Dim kanshu As String: kanshu = GetCode(kanshuStr)
|
||||
If innerDict.Exists(kanshu) Then
|
||||
Dim innermostDict As Object: Set innermostDict = innerDict(kanshu)
|
||||
Dim code As Variant
|
||||
For Each code In innermostDict.Keys
|
||||
If dropdownList = "" Then
|
||||
dropdownList = MakeSelect(code, innermostDict(code))
|
||||
Else
|
||||
dropdownList = dropdownList & "," & code
|
||||
End If
|
||||
Next code
|
||||
End If
|
||||
End If
|
||||
|
||||
If dropdownList <> "" Then
|
||||
With Me.Cells(rowNum, codeCol).Validation
|
||||
.Delete
|
||||
.Add Type:=xlValidateList, Formula1:=dropdownList
|
||||
.IgnoreBlank = True
|
||||
.InCellDropdown = True
|
||||
End With
|
||||
End If
|
||||
End Sub
|
||||
|
||||
' Clear row data and validation
|
||||
Private Sub ClearRowData(ByVal rowNum As Long)
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(Me.CodeName)
|
||||
|
||||
Dim startCol As String: startCol = sheetConf("StartCol")
|
||||
Dim endCol As String: endCol = sheetConf("EndCol")
|
||||
Dim errorCol As String: errorCol = sheetConf("ErrorCol")
|
||||
|
||||
Me.Range(Me.Cells(rowNum, startCol), Me.Cells(rowNum, endCol)).ClearContents
|
||||
Me.Range(Me.Cells(rowNum, startCol), Me.Cells(rowNum, endCol)).Interior.Color = vbWhite
|
||||
Me.Cells(rowNum, errorCol).ClearContents
|
||||
|
||||
Dim clearValidationCols As Variant
|
||||
clearValidationCols = Array("I", "J", "U", "V", "X", "AB", "AC", "AE", "AI", "AJ", "AL", "AP", "AQ", "AS")
|
||||
Dim col As Variant
|
||||
For Each col In clearValidationCols
|
||||
Me.Range(col & rowNum).Validation.Delete
|
||||
Next col
|
||||
End Sub
|
||||
|
||||
' Validation logic
|
||||
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
|
||||
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim startCol As String: startCol = sheetConf("StartCol")
|
||||
Dim endCol As String: endCol = sheetConf("EndCol")
|
||||
Dim errorCol As String: errorCol = sheetConf("ErrorCol")
|
||||
|
||||
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol))
|
||||
clearRange.Interior.Color = vbWhite
|
||||
|
||||
' Required columns: C-G, K-N, AW
|
||||
Dim requiredCols As Variant
|
||||
requiredCols = Array("C", "D", "E", "F", "G", "L", "M", "N", "AW")
|
||||
Dim col As Variant
|
||||
For Each col In requiredCols
|
||||
If Trim(Me.Range(col & rowNum).Value & "") = "" Then
|
||||
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", col & rowNum)
|
||||
Me.Range(col & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
Next col
|
||||
|
||||
' validate date
|
||||
Dim colIndex As Variant
|
||||
For Each colIndex In DATE_COLS()
|
||||
Dim cellDate As String: cellDate = Trim(Me.Cells(rowNum, colIndex).Value)
|
||||
If cellDate <> "" And Not IsDate(cellDate) Then
|
||||
Dim letter As String: letter = Split(Me.Cells(1, colIndex).Address, "$")(1)
|
||||
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E001", letter & rowNum)
|
||||
Me.Range(letter & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
Next colIndex
|
||||
|
||||
' validate number
|
||||
For Each col In NUMBER_COLS()
|
||||
Dim cellNumber As String: cellNumber = Trim(Me.Cells(rowNum, col).Value)
|
||||
If cellNumber <> "" And Not IsNumeric(cellNumber) Then
|
||||
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E001", col & rowNum)
|
||||
Me.Range(col & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
Next col
|
||||
|
||||
' validate CodeSelect
|
||||
' G column [todoke Cde]
|
||||
Dim ColG As String: ColG = "G"
|
||||
Dim z4Cache As Object: Set z4Cache = GetCache("Z4")
|
||||
Dim todokeCde As String: todokeCde = GetCode(Trim(Me.Cells(rowNum, ColG).Value))
|
||||
If Not z4Cache.Exists(todokeCde) Then
|
||||
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E001", ColG & rowNum)
|
||||
Me.Range(ColG & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' I column [address1 J column address2]
|
||||
Dim o1Cache As Object: Set o1Cache = GetCache("O1")
|
||||
Dim ColI As String: ColI = "I"
|
||||
Dim ColJ As String: ColJ = "J"
|
||||
Dim address1 As String: address1 = Trim(Me.Cells(rowNum, ColI).Value)
|
||||
Dim address2 As String: address2 = Trim(Me.Cells(rowNum, ColJ).Value)
|
||||
If address1 = "" Then
|
||||
If address2 <> "" Then
|
||||
Me.Cells(rowNum, errorCol).Value = ColJ & " column is invalid"
|
||||
Me.Range(ColJ & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
Else
|
||||
Dim empNo As String: empNo = Trim(Me.Cells(rowNum, 3).Value)
|
||||
If Not o1Cache.Exists(empNo) Then
|
||||
Me.Cells(rowNum, errorCol).Value = ColI & " column is invalid"
|
||||
Me.Range(ColI & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim innerDict As Object: Set innerDict = o1Cache(empNo)
|
||||
If Not innerDict.Exists(address1) Then
|
||||
Me.Cells(rowNum, errorCol).Value = ColI & " column is invalid"
|
||||
Me.Range(ColI & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
Dim addr2Dict As Object: Set addr2Dict = innerDict(address1)
|
||||
If Not addr2Dict.Exists(address2) Then
|
||||
Me.Cells(rowNum, errorCol).Value = ColJ & " column is invalid"
|
||||
Me.Range(ColJ & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
End If
|
||||
|
||||
' K column
|
||||
Dim ColK As String: ColK = "K"
|
||||
If Trim(Me.Cells(rowNum, ColK).Value) <> "" Then
|
||||
Me.Cells(rowNum, errorCol).Value = ColK & " column can not be input"
|
||||
Me.Range(ColK & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' validate CodeSelect
|
||||
' M column [oufuku]
|
||||
Dim ColM As String: ColM = "M"
|
||||
Dim oufukuList As Object: Set oufukuList = GetCache("oufukuList")
|
||||
Dim oufukuCde As String: oufukuCde = GetCode(Trim(Me.Cells(rowNum, ColM).Value))
|
||||
If Not oufukuList.Exists(oufukuCde) Then
|
||||
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E001", ColM & rowNum)
|
||||
Me.Range(ColM & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' validate CodeSelect
|
||||
' N column [koutai]
|
||||
Dim ColN As String: ColN = "N"
|
||||
Dim koutaiList As Object: Set koutaiList = GetCache("koutaiList")
|
||||
Dim koutaiCde As String: koutaiCde = GetCode(Trim(Me.Cells(rowNum, ColN).Value))
|
||||
If Not koutaiList.Exists(koutaiCde) Then
|
||||
Me.Cells(rowNum, errorCol).Value = ColN & " column is invalid"
|
||||
Me.Range(ColN & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' validate KUKAN_CODE_COLS (S, Z, AG, AN) and related columns
|
||||
Dim m1Cache As Object: Set m1Cache = GetCache("M1")
|
||||
Dim m2Cache As Object: Set m2Cache = GetCache("M2")
|
||||
Dim kukanCols As Variant
|
||||
kukanCols = Array(KUKAN_TRANSPORT_COLS, KUKAN_STATION_COLS, KUKAN_ARRIVAL_COLS, KUKAN_TICKET_COLS, KUKAN_CODE2_COLS, KUKAN_START_DAY_COLS)
|
||||
|
||||
Dim kukanIdx As Long
|
||||
For kukanIdx = LBound(KUKAN_CODE_COLS) To UBound(KUKAN_CODE_COLS)
|
||||
Dim kukanCol As Long: kukanCol = KUKAN_CODE_COLS(kukanIdx)
|
||||
Dim kukanCode As String: kukanCode = Trim(Me.Cells(rowNum, kukanCol).Value)
|
||||
Dim kukanLetter As String: kukanLetter = Split(Me.Cells(1, kukanCol).Address, "$")(1)
|
||||
|
||||
If kukanCode <> "" Then
|
||||
' KUKAN_CODE has value, check if exists in m1Cache
|
||||
If Not m1Cache.Exists(kukanCode) Then
|
||||
Me.Cells(rowNum, errorCol).Value = kukanLetter & " column does not exist"
|
||||
Me.Range(kukanLetter & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' Validate KUKAN_TICKET_COLS and KUKAN_CODE2_COLS
|
||||
Dim ticketCol As Long: ticketCol = KUKAN_TICKET_COLS(kukanIdx)
|
||||
Dim code2Col As Long: code2Col = KUKAN_CODE2_COLS(kukanIdx)
|
||||
Dim ticketVal As String: ticketVal = GetCode(Trim(Me.Cells(rowNum, ticketCol).Value))
|
||||
Dim code2Val As String: code2Val = GetCode(Trim(Me.Cells(rowNum, code2Col).Value))
|
||||
Dim ticketLetter As String: ticketLetter = Split(Me.Cells(1, ticketCol).Address, "$")(1)
|
||||
Dim code2Letter As String: code2Letter = Split(Me.Cells(1, code2Col).Address, "$")(1)
|
||||
|
||||
If ticketVal = "" Then
|
||||
Me.Cells(rowNum, errorCol).Value = ticketLetter & " column must be input"
|
||||
Me.Range(ticketLetter & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
If ticketVal = "0" Then
|
||||
If code2Val <> "" Then
|
||||
Me.Cells(rowNum, errorCol).Value = code2Letter & " column is invalid"
|
||||
Me.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
Else
|
||||
' Check if ticket exists in m2Cache for this kukanCode
|
||||
Dim kanshuDict As Object
|
||||
If m2Cache.Exists(kukanCode) Then
|
||||
Set kanshuDict = m2Cache(kukanCode)
|
||||
If Not kanshuDict.Exists(ticketVal) Then
|
||||
Me.Cells(rowNum, errorCol).Value = ticketLetter & " column is invalid"
|
||||
Me.Range(ticketLetter & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' If code2 also has value, verify it exists in m2Cache
|
||||
If code2Val = "" Then
|
||||
Me.Cells(rowNum, errorCol).Value = code2Letter & " column should be input"
|
||||
Me.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
Else
|
||||
Dim codeDict As Object: Set codeDict = kanshuDict(ticketVal)
|
||||
If Not codeDict.Exists(code2Val) Then
|
||||
Me.Cells(rowNum, errorCol).Value = code2Letter & " column is invalid"
|
||||
Me.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
End If
|
||||
End If
|
||||
End If
|
||||
Else
|
||||
' KUKAN_CODE is empty, check that related columns are also empty
|
||||
Dim colGroup As Variant
|
||||
For Each colGroup In kukanCols
|
||||
Dim checkCol As Long: checkCol = colGroup(kukanIdx)
|
||||
Dim checkVal As String: checkVal = Trim(Me.Cells(rowNum, checkCol).Value)
|
||||
If checkVal <> "" Then
|
||||
Dim checkLetter As String: checkLetter = Split(Me.Cells(1, checkCol).Address, "$")(1)
|
||||
Me.Cells(rowNum, errorCol).Value = checkLetter & " column requires " & kukanLetter & " column"
|
||||
Me.Range(checkLetter & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
Next colGroup
|
||||
End If
|
||||
Next kukanIdx
|
||||
|
||||
' Validate KUKAN_CODE_COLS for duplicates (non-empty only)
|
||||
Dim kukanCodes As Object: Set kukanCodes = CreateObject("Scripting.Dictionary")
|
||||
For kukanIdx = LBound(KUKAN_CODE_COLS) To UBound(KUKAN_CODE_COLS)
|
||||
kukanCol = KUKAN_CODE_COLS(kukanIdx)
|
||||
kukanCode = Trim(Me.Cells(rowNum, kukanCol).Value)
|
||||
If kukanCode <> "" Then
|
||||
If kukanCodes.Exists(kukanCode) Then
|
||||
kukanLetter = Split(Me.Cells(1, kukanCol).Address, "$")(1)
|
||||
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E003", kukanLetter & rowNum)
|
||||
Me.Range(kukanLetter & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
Else
|
||||
kukanCodes.Add kukanCode, True
|
||||
End If
|
||||
End If
|
||||
Next kukanIdx
|
||||
|
||||
' Validate H, BB, BC columns
|
||||
Dim linkCellValue As String: linkCellValue = Me.Cells(3, "H").Value
|
||||
Dim ColBB As String: ColBB = "BB"
|
||||
Dim ColBC As String: ColBC = "BC"
|
||||
Dim valBB As String: valBB = Trim(Me.Cells(rowNum, ColBB).Value)
|
||||
Dim valBC As String: valBC = Trim(Me.Cells(rowNum, ColBC).Value)
|
||||
|
||||
If linkCellValue = "1" Then
|
||||
' If code = "1", BB and BC must be empty
|
||||
If valBB <> "" Then
|
||||
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E005", ColBB & rowNum)
|
||||
Me.Range(ColBB & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
If valBC <> "" Then
|
||||
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E005", ColBC & rowNum)
|
||||
Me.Range(ColBC & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
ElseIf linkCellValue = "2" Then
|
||||
' If code = "2", BB and BC must have value
|
||||
If valBB = "" Then
|
||||
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", ColBB & rowNum)
|
||||
Me.Range(ColBB & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
If valBC = "" Then
|
||||
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", ColBC & rowNum)
|
||||
Me.Range(ColBC & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
End If
|
||||
|
||||
Me.Cells(rowNum, errorCol).ClearContents
|
||||
End Sub
|
||||
167
src/sh/tuk/sheet/M1.cls
Normal file
167
src/sh/tuk/sheet/M1.cls
Normal file
@@ -0,0 +1,167 @@
|
||||
' ============================================================
|
||||
' Module Name: Master_Kukan
|
||||
' Module Desc: M1 Kukan master data management (import/export/validate)
|
||||
' Module Methods:
|
||||
' - CreateEnumDropdown
|
||||
' - Worksheet_Change
|
||||
' - Validate
|
||||
' ============================================================
|
||||
|
||||
' Create dropdown for L column
|
||||
Private Sub CreateEnumDropdown(ByVal rowNum As Long)
|
||||
Dim tokubetuList As Object: Set tokubetuList = GetCache("tokubetuList")
|
||||
' Build dropdown list from tokubetuList
|
||||
Dim dropdownList As String
|
||||
dropdownList = ""
|
||||
|
||||
Dim key As Variant
|
||||
For Each key In tokubetuList.Keys
|
||||
If dropdownList = "" Then
|
||||
dropdownList = key
|
||||
Else
|
||||
dropdownList = dropdownList & "," & key
|
||||
End If
|
||||
Next key
|
||||
|
||||
With Me.Range("L" & rowNum).Validation
|
||||
.Delete
|
||||
.Add Type:=xlValidateList, Formula1:=dropdownList
|
||||
.IgnoreBlank = True
|
||||
.InCellDropdown = True
|
||||
.InputTitle = ""
|
||||
.InputMessage = ""
|
||||
End With
|
||||
|
||||
End Sub
|
||||
|
||||
'
|
||||
Private Sub Worksheet_Change(ByVal Target As Range)
|
||||
Dim HasHeaderEdit As Boolean: HasHeaderEdit = CheckHeaderEdit(Me, Target)
|
||||
If HasHeaderEdit = True Then Exit Sub
|
||||
|
||||
' === Column C changes: Create L column dropdown ===
|
||||
If Target.Column = 3 And Target.Row >= 7 Then
|
||||
Dim cell As Range
|
||||
For Each cell In Target
|
||||
If Trim(cell.Value) = "" Then
|
||||
Me.Cells(cell.Row, 12).Validation.Delete
|
||||
Call ClearDataRow(Me, START_COL + 1, END_COL, cell.Row, ERROR_COL)
|
||||
Else
|
||||
Call CreateEnumDropdown(cell.Row)
|
||||
End If
|
||||
Next
|
||||
End If
|
||||
|
||||
' === Column D changes: Fill E column ===
|
||||
If Target.Column = 4 And Target.Row >= 7 Then
|
||||
Dim z1Cache As Object: Set z1Cache = GetCache("Z1")
|
||||
|
||||
Dim cellD As Range
|
||||
For Each cellD In Target
|
||||
Dim dVal As String: dVal = Trim(cellD.Value)
|
||||
If dVal = "" Then
|
||||
Me.Cells(cellD.Row, 5).ClearContents
|
||||
Else
|
||||
If Not z1Cache Is Nothing And z1Cache.Exists(dVal) Then
|
||||
Dim valsD As Variant: valsD = z1Cache(dVal)
|
||||
Me.Cells(cellD.Row, 5).Value = valsD(0)
|
||||
Else
|
||||
Me.Cells(cellD.Row, 5).ClearContents
|
||||
End If
|
||||
End If
|
||||
Next
|
||||
End If
|
||||
End Sub
|
||||
|
||||
Private Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
|
||||
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim startCol As String: startCol = sheetConf("StartCol")
|
||||
Dim endCol As String: endCol = sheetConf("EndCol")
|
||||
Dim errorCol As String: errorCol = sheetConf("ErrorCol")
|
||||
|
||||
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol))
|
||||
clearRange.Interior.Color = vbWhite
|
||||
|
||||
' Check column required
|
||||
Dim colLetter As Variant
|
||||
For Each colLetter In Array("C", "D", "E", "F", "G", "I", "L")
|
||||
If Trim(ws.Range(colLetter & rowNum).Value) = "" Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", colLetter & rowNum)
|
||||
ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
Next colLetter
|
||||
|
||||
' Check column numeric
|
||||
For Each colLetter In Array("H", "I", "J", "N")
|
||||
Dim val As String: val = Trim(ws.Range(colLetter & rowNum).Value)
|
||||
If val <> "" And Not IsNumeric(val) Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E011", colLetter & rowNum)
|
||||
ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
Next colLetter
|
||||
|
||||
' Check C column repeat
|
||||
Dim cValue As String: cValue = Trim(ws.Range("C" & rowNum).Value)
|
||||
Dim foundCell As Range
|
||||
Set foundCell = ws.Range("C7:C" & lastDataRow).Find(What:=cValue, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
|
||||
If Not foundCell Is Nothing Then
|
||||
If foundCell.Row <> rowNum Then
|
||||
ws.Cells(rowNum, errorCol).Value = "C column value is duplicated"
|
||||
ws.Range("C" & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
End If
|
||||
|
||||
' Check D and E column in the cache
|
||||
Dim z1Cache As Object: Set z1Cache = GetCache("Z1")
|
||||
|
||||
Dim dValue As String: dValue = Trim(ws.Range("D" & rowNum).Value)
|
||||
Dim eValue As String: eValue = Trim(ws.Range("E" & rowNum).Value)
|
||||
|
||||
If Not z1Cache.Exists(dValue) Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E004", "D" & rowNum)
|
||||
ws.Range("D" & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
Else
|
||||
Dim valueArray As Variant
|
||||
valueArray = z1Cache(dValue)
|
||||
If Not IsArray(valueArray) Or UBound(valueArray) < 0 Then
|
||||
ws.Cells(rowNum, errorCol).Value = "Invalid reference data for D column."
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim expectedEValue As String
|
||||
expectedEValue = Trim(CStr(valueArray(0)))
|
||||
|
||||
If eValue <> expectedEValue Then
|
||||
ws.Cells(rowNum, errorCol).Value = "E column does not match reference data."
|
||||
ws.Range("E" & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
End If
|
||||
|
||||
' Check L column in the tokubetuList
|
||||
Dim tokubetuList As Object: Set tokubetuList = GetCache("tokubetuList")
|
||||
Dim lValue As String: lValue = Trim(ws.Range("L" & rowNum).Value)
|
||||
If Not tokubetuList.Exists(lValue) Then
|
||||
ws.Cells(rowNum, errorCol).Value = "L column does not exist."
|
||||
ws.Range("L" & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' Check if M2 uses this M1 kukan code
|
||||
Dim m2Cache As Object: Set m2Cache = GetCache("M2")
|
||||
If Not m2Cache.Exists(cValue) Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("W001", cValue)
|
||||
ws.Range("C" & rowNum).Interior.Color = RGB(255, 128, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' Validation passed - clear error
|
||||
ws.Cells(rowNum, errorCol).ClearContents
|
||||
End Sub
|
||||
400
src/sh/tuk/sheet/M2.cls
Normal file
400
src/sh/tuk/sheet/M2.cls
Normal file
@@ -0,0 +1,400 @@
|
||||
' ============================================================
|
||||
' Module Name: Master_Kukan_detail
|
||||
' Module Desc: M2 Kukan detail master data management
|
||||
' Module Methods:
|
||||
' - Worksheet_Change
|
||||
' - FillFromM1
|
||||
' - validateButton_Click
|
||||
' - Validate
|
||||
' ============================================================
|
||||
Private Sub Worksheet_Change(ByVal Target As Range)
|
||||
Dim HasHeaderEdit As Boolean: HasHeaderEdit = CheckHeaderEdit(Me, Target)
|
||||
If HasHeaderEdit = True Then Exit Sub
|
||||
|
||||
If Target.EntireRow.Address = Target.Address Then Exit Sub
|
||||
|
||||
Dim watchArea As Range
|
||||
With Me
|
||||
Set watchArea = Union( _
|
||||
.Columns("C"), _
|
||||
.Columns("I:R") _
|
||||
)
|
||||
End With
|
||||
Dim intersectRng As Range: Set intersectRng = Application.Intersect(Target, watchArea)
|
||||
If intersectRng Is Nothing Then Exit Sub
|
||||
|
||||
If Target.Row < 7 Then Exit Sub
|
||||
|
||||
Application.EnableEvents = False
|
||||
On Error GoTo Finally
|
||||
|
||||
' === Fill D, E when C column changes ===
|
||||
If Target.Column = 3 Then
|
||||
Dim cell As Range
|
||||
For Each cell In Target
|
||||
If Trim(cell.Value) = "" Then
|
||||
Call ClearRowData(Me, cell.Row)
|
||||
GoTo Finally
|
||||
Else
|
||||
Call FillFromM1(cell.Row)
|
||||
End If
|
||||
Next
|
||||
End If
|
||||
|
||||
' === Create J dropdown when I column changes ===
|
||||
If Target.Column = 9 Then
|
||||
Dim cellI As Range
|
||||
For Each cellI In Target
|
||||
' clear
|
||||
Me.Range(Me.Cells(cellI.Row, 10), Me.Cells(cellI.Row, 18)).ClearContents
|
||||
Me.Cells(cellI.Row, 11).Validation.Delete
|
||||
Me.Range(Me.Cells(cellI.Row, 10), Me.Cells(cellI.Row, 18)).Interior.Color = vbWhite
|
||||
Call CreateJDropdown(cellI.Row)
|
||||
Next
|
||||
End If
|
||||
|
||||
' === Fill K column when J column changes ===
|
||||
If Target.Column = 10 Then
|
||||
Dim cellJ As Range
|
||||
For Each cellJ In Target
|
||||
Call FillKFromJ(cellJ.Row)
|
||||
Next
|
||||
End If
|
||||
|
||||
Dim kenshuKbn As String: kenshuKbn = Trim(Me.Range("I" & Target.Row).value)
|
||||
Dim restrictedCols As Range
|
||||
If kenshuKbn = "1" Then
|
||||
Set restrictedCols = Union(Me.Columns("K"), Me.Columns("O"), Me.Columns("P"), Me.Columns("Q"), Me.Columns("R"))
|
||||
If Not Intersect(Target, restrictedCols) Is Nothing Then
|
||||
Application.EnableEvents = False
|
||||
MsgBox "can not be input", vbExclamation
|
||||
Application.Undo
|
||||
Application.EnableEvents = True
|
||||
Exit Sub
|
||||
End If
|
||||
Else
|
||||
Set restrictedCols = Me.Range("K:R") '
|
||||
If Not Intersect(Target, restrictedCols) Is Nothing Then
|
||||
Application.EnableEvents = False
|
||||
MsgBox "can not be input", vbExclamation
|
||||
Application.Undo
|
||||
Application.EnableEvents = True
|
||||
Exit Sub
|
||||
End If
|
||||
End If
|
||||
|
||||
Finally:
|
||||
Application.EnableEvents = True '
|
||||
End Sub
|
||||
|
||||
Private Sub FillKFromJ(ByVal rowNum As Long)
|
||||
Dim iValue As String: iValue = Trim(Me.Range("I" & rowNum).Value)
|
||||
Dim jValue As String: jValue = Trim(Me.Range("J" & rowNum).Value)
|
||||
Dim code As String: code = GetCode(jValue)
|
||||
|
||||
If jValue = "" Then
|
||||
Me.Range("K" & rowNum).ClearContents
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' Get cache based on I column value
|
||||
Dim cache As Object
|
||||
Select Case iValue
|
||||
Case "1"
|
||||
Set cache = GetCache("T1")
|
||||
Case "2"
|
||||
Set cache = GetCache("T2")
|
||||
Case "3"
|
||||
Set cache = GetCache("T3")
|
||||
Case Else
|
||||
Exit Sub
|
||||
End Select
|
||||
|
||||
If cache Is Nothing Then Exit Sub
|
||||
|
||||
' Check if J value exists in cache
|
||||
|
||||
If cache.Exists(code) Then
|
||||
Dim cacheVal As Variant: cacheVal = cache(code)
|
||||
Me.Range("J" & rowNum).Value = Trim(code)
|
||||
Me.Range("K" & rowNum).Value = Trim(cacheVal(0))
|
||||
End If
|
||||
|
||||
Select Case iValue
|
||||
Case "1"
|
||||
Exit Sub
|
||||
Case "2"
|
||||
Me.Range("L" & rowNum).Value = Trim(cacheVal(2))
|
||||
Me.Range("M" & rowNum).Value = Trim(cacheVal(3))
|
||||
Me.Range("N" & rowNum).Value = Trim(cacheVal(4))
|
||||
Me.Range("O" & rowNum).Value = Trim(cacheVal(5))
|
||||
Me.Range("P" & rowNum).Value = Trim(cacheVal(6))
|
||||
Me.Range("Q" & rowNum).Value = Trim(cacheVal(7))
|
||||
Case "3"
|
||||
Me.Range("L" & rowNum).Value = Trim(cacheVal(1))
|
||||
Me.Range("M" & rowNum).Value = Trim(cacheVal(2))
|
||||
Case Else
|
||||
Exit Sub
|
||||
End Select
|
||||
|
||||
End Sub
|
||||
|
||||
Private Sub CreateJDropdown(ByVal rowNum As Long)
|
||||
Dim iValue As String: iValue = Trim(Me.Range("I" & rowNum).Value)
|
||||
Dim targetCell As Range: Set targetCell = Me.Range("J" & rowNum)
|
||||
|
||||
' Clear existing validation
|
||||
targetCell.Validation.Delete
|
||||
targetCell.ClearContents
|
||||
|
||||
' Get cache based on I column value
|
||||
Dim cache As Object
|
||||
Select Case iValue
|
||||
Case "1"
|
||||
Set cache = GetCache("T1")
|
||||
Me.Range("O" & rowNum).Interior.Color = RGB(192, 192, 192)
|
||||
Me.Range("P" & rowNum).Interior.Color = RGB(192, 192, 192)
|
||||
Me.Range("Q" & rowNum).Interior.Color = RGB(192, 192, 192)
|
||||
Case "2"
|
||||
Set cache = GetCache("T2")
|
||||
Case "3"
|
||||
Set cache = GetCache("T3")
|
||||
Me.Range("N" & rowNum).Interior.Color = RGB(192, 192, 192)
|
||||
Me.Range("O" & rowNum).Interior.Color = RGB(192, 192, 192)
|
||||
Me.Range("P" & rowNum).Interior.Color = RGB(192, 192, 192)
|
||||
Me.Range("Q" & rowNum).Interior.Color = RGB(192, 192, 192)
|
||||
Case Else
|
||||
Exit Sub
|
||||
End Select
|
||||
|
||||
If cache Is Nothing Then Exit Sub
|
||||
|
||||
' Build dropdown list from cache
|
||||
Dim dropdownList As String: dropdownList = ""
|
||||
Dim key As Variant
|
||||
For Each key In cache.Keys
|
||||
Dim displayText As String: displayText = MakeSelect(key, cache(key)(0))
|
||||
If dropdownList = "" Then
|
||||
dropdownList = displayText
|
||||
Else
|
||||
dropdownList = dropdownList & "," & displayText
|
||||
End If
|
||||
Next key
|
||||
|
||||
If dropdownList <> "" Then
|
||||
With targetCell.Validation
|
||||
.Add Type:=xlValidateList, Formula1:=dropdownList
|
||||
.IgnoreBlank = True
|
||||
.InCellDropdown = True
|
||||
End With
|
||||
End If
|
||||
End Sub
|
||||
|
||||
Private Sub FillFromM1(ByVal rowNum As Long)
|
||||
Set ws = Me
|
||||
|
||||
Dim m1Cache As Object: Set m1Cache = GetCache("M1")
|
||||
Dim cValue As String: cValue = Trim(ws.Range("C" & rowNum).Value)
|
||||
|
||||
' Fill D, E, F, G, H columns from M1 cache
|
||||
' D = cache[1]: cache[2] (col 4: col 5)
|
||||
' E = cache[3] (col 6)
|
||||
' F = cache[4] (col 7)
|
||||
' G = cache[5] (col 9)
|
||||
' H = cache[6] (col 12)
|
||||
|
||||
' Check C column in the cache
|
||||
If Not m1Cache.Exists(cValue) Then
|
||||
ws.Cells(rowNum, 4).Value = ""
|
||||
ws.Cells(rowNum, 5).Value = ""
|
||||
ws.Cells(rowNum, 6).Value = ""
|
||||
ws.Cells(rowNum, 7).Value = ""
|
||||
ws.Cells(rowNum, 8).Value = ""
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim cacheVal As Variant: cacheVal = m1Cache(cValue)
|
||||
|
||||
' D column = cache[1]: cache[2]
|
||||
ws.Cells(rowNum, 4).Value = Trim(cacheVal(1)) & ":" & Trim(cacheVal(2))
|
||||
' E column = cache[3]
|
||||
ws.Cells(rowNum, 5).Value = Trim(cacheVal(3))
|
||||
' F column = cache[4]
|
||||
ws.Cells(rowNum, 6).Value = Trim(cacheVal(4))
|
||||
' G column = cache[5]
|
||||
ws.Cells(rowNum, 7).Value = Trim(cacheVal(5))
|
||||
' H column = cache[6]
|
||||
ws.Cells(rowNum, 8).Value = Trim(cacheVal(6))
|
||||
End Sub
|
||||
|
||||
Private Sub ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long)
|
||||
' Clear from D column onwards
|
||||
ws.Range(ws.Cells(rowNum, "D"), ws.Cells(rowNum, "R")).ClearContents
|
||||
ws.Range(ws.Cells(rowNum, "C"), ws.Cells(rowNum, "R")).Interior.Color = vbWhite
|
||||
ws.Cells(rowNum, "J").Validation.Delete
|
||||
ws.Cells(rowNum, "S").ClearContents
|
||||
End Sub
|
||||
|
||||
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
|
||||
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim startCol As String: startCol = sheetConf("StartCol")
|
||||
Dim endCol As String: endCol = sheetConf("EndCol")
|
||||
Dim errorCol As String: errorCol = sheetConf("ErrorCol")
|
||||
|
||||
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol))
|
||||
clearRange.Interior.Color = vbWhite
|
||||
|
||||
' Check C column in the cache
|
||||
Dim m1Cache As Object: Set m1Cache = GetCache("M1")
|
||||
|
||||
' C column check
|
||||
checkResult = CheckRequired(ws, rowNum, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
Dim cValue As String: cValue = Trim(ws.Range("C" & rowNum).Value)
|
||||
If Not m1Cache.Exists(cValue) Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E004", "C" & rowNum)
|
||||
ws.Range("C" & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' Check column required
|
||||
Dim colLetter As Variant
|
||||
For Each colLetter In Array("I", "J", "K", "L", "M")
|
||||
If Trim(ws.Range(colLetter & rowNum).Value) = "" Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", colLetter & rowNum)
|
||||
ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
Next colLetter
|
||||
|
||||
' Check column numeric (only if has value)
|
||||
Dim numericCols As Variant: numericCols = Array("L", "M", "N", "O", "P", "Q", "R")
|
||||
Dim col As Variant
|
||||
For Each col In numericCols
|
||||
Dim val As String: val = Trim(ws.Range(col & rowNum).Value & "")
|
||||
If val <> "" And Not IsNumeric(val) Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E011", col & rowNum)
|
||||
ws.Range(col & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
Next col
|
||||
|
||||
' Check I column in the kenshuKbn
|
||||
Dim kenshuList As Object: Set kenshuList = GetCache("kenshuList")
|
||||
Dim kenshuKbn As String: kenshuKbn = Trim(ws.Range("I" & rowNum).Value)
|
||||
If Not kenshuList.Exists(kenshuKbn) Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E012", "I" & rowNum)
|
||||
ws.Range("I" & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' Check J column in the T1, T2, T3
|
||||
Dim code As String: code = Trim(ws.Range("J" & rowNum).Value)
|
||||
Dim name As String: name = Trim(ws.Range("K" & rowNum).Value)
|
||||
Dim valueL As String: valueL = Trim(ws.Range("L" & rowNum).Value)
|
||||
Dim valueM As String: valueM = Trim(ws.Range("M" & rowNum).Value)
|
||||
Dim valueN As String: valueN = Trim(ws.Range("N" & rowNum).Value)
|
||||
Dim valueO As String: valueO = Trim(ws.Range("O" & rowNum).Value)
|
||||
Dim valueP As String: valueP = Trim(ws.Range("P" & rowNum).Value)
|
||||
Dim valueQ As String: valueQ = Trim(ws.Range("Q" & rowNum).Value)
|
||||
Dim cache As Object
|
||||
Dim requiredCols As Variant
|
||||
Dim equaledCols As Variant
|
||||
Dim emptyCols As Variant
|
||||
If kenshuKbn = "1" Then
|
||||
Set cache = GetCache("T1")
|
||||
' must input
|
||||
equaledCols = Array("K")
|
||||
requiredCols = Array("N")
|
||||
emptyCols = Array("O", "P", "Q", "R")
|
||||
End If
|
||||
|
||||
If kenshuKbn = "2" Then
|
||||
Set cache = GetCache("T2")
|
||||
' must input
|
||||
equaledCols = Array("K", "L", "M", "N", "O", "P", "Q")
|
||||
requiredCols = Array("N", "O", "P", "Q")
|
||||
emptyCols = Array("R")
|
||||
End If
|
||||
|
||||
If kenshuKbn = "3" Then
|
||||
Set cache = GetCache("T3")
|
||||
' must input
|
||||
equaledCols = Array("K", "L", "M")
|
||||
requiredCols = Array()
|
||||
emptyCols = Array("N", "O", "P", "Q", "R")
|
||||
End If
|
||||
|
||||
' code not exist check
|
||||
If Not cache.Exists(code) Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E004", "J" & rowNum)
|
||||
ws.Range("J" & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' Dim equaledColIndex As Long
|
||||
' For equaledColIndex = 0 To
|
||||
|
||||
' Dim equaledCol As Variant
|
||||
' For Each equaledCol In equaledCols
|
||||
' Dim equalValue As String: equalValue = Trim(ws.Range(equaledCol & rowNum).Value)
|
||||
' cache
|
||||
' If cache(code)(0) <> name Then
|
||||
' Exit Sub
|
||||
' End If
|
||||
' Me.Range(equaledCol & rowNum).Validation.Delete
|
||||
' Next equaledCol
|
||||
|
||||
Dim requiredCol As Variant
|
||||
For Each requiredCol In requiredCols
|
||||
Dim requiredValue As String: requiredValue = Trim(ws.Range(requiredCol & rowNum).Value)
|
||||
If requiredValue = "" Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", requiredCol & rowNum)
|
||||
ws.Range(requiredCol & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
Next requiredCol
|
||||
|
||||
Dim emptyCol As Variant
|
||||
For Each emptyCol In emptyCols
|
||||
Dim emptyValue As String: emptyValue = Trim(ws.Range(emptyCol & rowNum).Value)
|
||||
If emptyValue <> "" Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E005", emptyCol & rowNum)
|
||||
ws.Range(emptyCol & rowNum).Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
Next emptyCol
|
||||
|
||||
' check Duplicate
|
||||
Dim i As Long
|
||||
For i = 7 To rowNum - 1
|
||||
If Trim(ws.Cells(i, "C").Value) = cValue And Trim(ws.Cells(i, "I").Value) = kenshuKbn And Trim(ws.Cells(i, "J").Value) = code Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E013", i, checkValue)
|
||||
ws.Cells(rowNum, "C").Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
If Trim(ws.Cells(i, "C").Value) = cValue And Trim(ws.Cells(i, "I").Value) = kenshuKbn And Trim(ws.Cells(i, "K").Value) = name Then
|
||||
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E013", i, checkValue)
|
||||
ws.Cells(rowNum, "C").Interior.Color = RGB(255, 0, 0)
|
||||
Exit Sub
|
||||
End If
|
||||
Next i
|
||||
|
||||
ws.Cells(rowNum, errorCol).ClearContents
|
||||
|
||||
End Sub
|
||||
|
||||
Public Sub ImportCSVAndTriggerChange(ws As Worksheet, ByVal lastDataRow As Long)
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim startRow As Long: startRow = sheetConf("StartRow")
|
||||
Dim i As Long
|
||||
For i = startRow To lastDataRow
|
||||
Call FillFromM1(i)
|
||||
Next i
|
||||
End Sub
|
||||
5
src/sh/tuk/sheet/O1.cls
Normal file
5
src/sh/tuk/sheet/O1.cls
Normal file
@@ -0,0 +1,5 @@
|
||||
' ============================================================
|
||||
' Module Name: Master_address
|
||||
' Module Desc: O1 address master data management
|
||||
' Module Methods:
|
||||
' ============================================================
|
||||
6
src/sh/tuk/sheet/O2.cls
Normal file
6
src/sh/tuk/sheet/O2.cls
Normal file
@@ -0,0 +1,6 @@
|
||||
' ============================================================
|
||||
' Module Name: Master_507
|
||||
' Module Desc: O2 master data management (507)
|
||||
' Module Methods:
|
||||
' ============================================================
|
||||
' ====== (507) =======
|
||||
54
src/sh/tuk/sheet/T1.cls
Normal file
54
src/sh/tuk/sheet/T1.cls
Normal file
@@ -0,0 +1,54 @@
|
||||
' ============================================================
|
||||
' Module Name: Master_244
|
||||
' Module Desc: T1 master data management (244)
|
||||
' Module Methods:
|
||||
' - Validate
|
||||
' ============================================================
|
||||
'
|
||||
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
|
||||
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim startCol As String: startCol = sheetConf("StartCol")
|
||||
Dim endCol As String: endCol = sheetConf("EndCol")
|
||||
Dim errorCol As String: errorCol = sheetConf("ErrorCol")
|
||||
|
||||
' clear C~I columns background color
|
||||
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol))
|
||||
clearRange.Interior.Color = vbWhite
|
||||
|
||||
' C column check
|
||||
checkResult = CheckRequired(ws, rowNum, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckChar(ws, rowNum, 3, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckAlphanumeric(ws, rowNum, 3, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckDuplicate(ws, rowNum, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' D column check
|
||||
checkResult = CheckRequired(ws, rowNum, 4, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 4, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' E column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 5, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' F column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 6, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' G column check
|
||||
checkResult = Check01(ws, rowNum, 7, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
ws.Cells(rowNum, errorCol).ClearContents
|
||||
End Sub
|
||||
114
src/sh/tuk/sheet/T2.cls
Normal file
114
src/sh/tuk/sheet/T2.cls
Normal file
@@ -0,0 +1,114 @@
|
||||
' ============================================================
|
||||
' Module Name: Master_245
|
||||
' Module Desc: T2 master data management (245)
|
||||
' Module Methods:
|
||||
' - Validate
|
||||
' ============================================================
|
||||
'
|
||||
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
|
||||
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim startCol As String: startCol = sheetConf("StartCol")
|
||||
Dim endCol As String: endCol = sheetConf("EndCol")
|
||||
Dim errorCol As String: errorCol = sheetConf("ErrorCol")
|
||||
|
||||
' clear C~I columns background color
|
||||
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol))
|
||||
clearRange.Interior.Color = vbWhite
|
||||
|
||||
' C column check
|
||||
checkResult = CheckRequired(ws, rowNum, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckChar(ws, rowNum, 3, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckAlphanumeric(ws, rowNum, 3, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckDuplicate(ws, rowNum, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' D column check
|
||||
checkResult = CheckRequired(ws, rowNum, 4, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 4, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' E column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 5, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' F column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 6, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' G column check
|
||||
checkResult = Check01(ws, rowNum, 7, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' H column check number
|
||||
checkResult = CheckRequired(ws, rowNum, 8, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckNumber(ws, rowNum, 8, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckNumberOver(ws, rowNum, 8, 6, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' I column check number
|
||||
checkResult = CheckRequired(ws, rowNum, 9, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckNumber(ws, rowNum, 9, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckNumberOver(ws, rowNum, 9, 5, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' J column check number
|
||||
checkResult = CheckRequired(ws, rowNum, 10, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckNumber(ws, rowNum, 10, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckNumberOver(ws, rowNum, 10, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' K column check number
|
||||
checkResult = CheckRequired(ws, rowNum, 11, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckNumber(ws, rowNum, 11, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckNumberOver(ws, rowNum, 11, 5, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' L column check number
|
||||
checkResult = CheckRequired(ws, rowNum, 12, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckNumber(ws, rowNum, 12, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckNumberOver(ws, rowNum, 12, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' M column check number
|
||||
checkResult = CheckRequired(ws, rowNum, 13, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckNumber(ws, rowNum, 13, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckNumberOver(ws, rowNum, 13, 5, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
ws.Cells(rowNum, errorCol).ClearContents
|
||||
End Sub
|
||||
74
src/sh/tuk/sheet/T3.cls
Normal file
74
src/sh/tuk/sheet/T3.cls
Normal file
@@ -0,0 +1,74 @@
|
||||
' ============================================================
|
||||
' Module Name: Master_246
|
||||
' Module Desc: T3 master data management (246)
|
||||
' Module Methods:
|
||||
' - Validate
|
||||
' ============================================================
|
||||
'
|
||||
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
|
||||
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim startCol As String: startCol = sheetConf("StartCol")
|
||||
Dim endCol As String: endCol = sheetConf("EndCol")
|
||||
Dim errorCol As String: errorCol = sheetConf("ErrorCol")
|
||||
|
||||
' clear C~I columns background color
|
||||
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol))
|
||||
clearRange.Interior.Color = vbWhite
|
||||
|
||||
' C column check
|
||||
checkResult = CheckRequired(ws, rowNum, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckChar(ws, rowNum, 3, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckAlphanumeric(ws, rowNum, 3, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckDuplicate(ws, rowNum, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' D column check
|
||||
checkResult = CheckRequired(ws, rowNum, 4, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 4, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' E column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 5, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' F column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 6, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' G column check
|
||||
checkResult = Check01(ws, rowNum, 7, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' H column check number
|
||||
checkResult = CheckRequired(ws, rowNum, 8, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckNumber(ws, rowNum, 8, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckNumberOver(ws, rowNum, 8, 6, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' I column check number
|
||||
checkResult = CheckRequired(ws, rowNum, 9, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckNumber(ws, rowNum, 9, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckNumberOver(ws, rowNum, 9, 6, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
ws.Cells(rowNum, errorCol).ClearContents
|
||||
End Sub
|
||||
64
src/sh/tuk/sheet/Z1.cls
Normal file
64
src/sh/tuk/sheet/Z1.cls
Normal file
@@ -0,0 +1,64 @@
|
||||
' ============================================================
|
||||
' Module Name: Master_222
|
||||
' Module Desc: Z1 master data management (222)
|
||||
' Module Methods:
|
||||
' - Validate
|
||||
' ============================================================
|
||||
'
|
||||
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
|
||||
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim startCol As String: startCol = sheetConf("StartCol")
|
||||
Dim endCol As String: endCol = sheetConf("EndCol")
|
||||
Dim errorCol As String: errorCol = sheetConf("ErrorCol")
|
||||
|
||||
' clear C~I columns background color
|
||||
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol))
|
||||
clearRange.Interior.Color = vbWhite
|
||||
|
||||
Dim checkResult As Boolean: checkResult = False
|
||||
|
||||
' C column check
|
||||
checkResult = CheckRequired(ws, rowNum, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckChar(ws, rowNum, 3, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckAlphanumeric(ws, rowNum, 3, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckDuplicate(ws, rowNum, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' D column check
|
||||
checkResult = CheckRequired(ws, rowNum, 4, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 4, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' E column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 5, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' F column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 6, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' G column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 7, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' H column check
|
||||
checkResult = Check01(ws, rowNum, 8, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' I column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 9, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
ws.Cells(rowNum, errorCol).ClearContents
|
||||
End Sub
|
||||
54
src/sh/tuk/sheet/Z2.cls
Normal file
54
src/sh/tuk/sheet/Z2.cls
Normal file
@@ -0,0 +1,54 @@
|
||||
' ============================================================
|
||||
' Module Name: Master_223
|
||||
' Module Desc: Z2 master data management (223)
|
||||
' Module Methods:
|
||||
' - Validate
|
||||
' ============================================================
|
||||
'
|
||||
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
|
||||
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim startCol As String: startCol = sheetConf("StartCol")
|
||||
Dim endCol As String: endCol = sheetConf("EndCol")
|
||||
Dim errorCol As String: errorCol = sheetConf("ErrorCol")
|
||||
|
||||
' clear C~I columns background color
|
||||
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol))
|
||||
clearRange.Interior.Color = vbWhite
|
||||
|
||||
' C column check
|
||||
checkResult = CheckRequired(ws, rowNum, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckChar(ws, rowNum, 3, 1, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckAlphanumeric(ws, rowNum, 3, 1, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckDuplicate(ws, rowNum, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' D column check
|
||||
checkResult = CheckRequired(ws, rowNum, 4, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 4, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' E column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 5, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' F column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 6, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' G column check
|
||||
checkResult = Check01(ws, rowNum, 7, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
ws.Cells(rowNum, errorCol).ClearContents
|
||||
End Sub
|
||||
57
src/sh/tuk/sheet/Z3.cls
Normal file
57
src/sh/tuk/sheet/Z3.cls
Normal file
@@ -0,0 +1,57 @@
|
||||
' ============================================================
|
||||
' Module Name: Master_Z3_224
|
||||
' Module Desc: Z3 master data management (224)
|
||||
' Module Methods:
|
||||
' - Validate
|
||||
' ============================================================
|
||||
'
|
||||
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim startCol As String: startCol = sheetConf("StartCol")
|
||||
Dim endCol As String: endCol = sheetConf("EndCol")
|
||||
Dim errorCol As String: errorCol = sheetConf("ErrorCol")
|
||||
|
||||
' clear C~I columns background color
|
||||
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol))
|
||||
clearRange.Interior.Color = vbWhite
|
||||
|
||||
' C column check
|
||||
checkResult = CheckRequired(ws, rowNum, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckChar(ws, rowNum, 3, 2, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckAlphanumeric(ws, rowNum, 3, 2, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckDuplicate(ws, rowNum, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' D column check
|
||||
checkResult = CheckRequired(ws, rowNum, 4, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 4, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' E column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 5, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' F column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 6, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' G column check
|
||||
checkResult = Check01(ws, rowNum, 7, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' H column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 8, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
ws.Cells(rowNum, errorCol).ClearContents
|
||||
End Sub
|
||||
61
src/sh/tuk/sheet/Z4.cls
Normal file
61
src/sh/tuk/sheet/Z4.cls
Normal file
@@ -0,0 +1,61 @@
|
||||
' ============================================================
|
||||
' Module Name: Master_Z4_220
|
||||
' Module Desc: Z4 master data management (220)
|
||||
' Module Methods:
|
||||
' - Validate
|
||||
' ============================================================
|
||||
'
|
||||
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
|
||||
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
|
||||
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
|
||||
|
||||
Dim startCol As String: startCol = sheetConf("StartCol")
|
||||
Dim endCol As String: endCol = sheetConf("EndCol")
|
||||
Dim errorCol As String: errorCol = sheetConf("ErrorCol")
|
||||
|
||||
' clear C~I columns background color
|
||||
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol))
|
||||
clearRange.Interior.Color = vbWhite
|
||||
|
||||
' C column check
|
||||
checkResult = CheckRequired(ws, rowNum, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckChar(ws, rowNum, 3, 2, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckAlphanumeric(ws, rowNum, 3, 2, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckDuplicate(ws, rowNum, 3, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' D column check
|
||||
checkResult = CheckRequired(ws, rowNum, 4, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 4, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' E column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 5, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' F column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 6, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' G column check
|
||||
checkResult = Check01(ws, rowNum, 7, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' H column check
|
||||
checkResult = CheckVarcharOver(ws, rowNum, 8, 80, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
' I column check
|
||||
checkResult = Check12(ws, rowNum, 9, errorCol)
|
||||
If checkResult = False Then Exit Sub
|
||||
|
||||
ws.Cells(rowNum, errorCol).ClearContents
|
||||
End Sub
|
||||
Reference in New Issue
Block a user