vba/vba_code_kotsu_master.txt

Sub ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long)
    ' Clear from D column onwards
    ws.Range(ws.Cells(rowNum, 4), ws.Cells(rowNum, 15)).ClearContents
    ws.Cells(rowNum, 19).ClearContents ' Q column error info
End Sub

Sub ImportMasterDetailData()
    Dim filePath As String
    Dim fileDialog As FileDialog
    Dim wsTarget As Worksheet
    Dim stream As Object
    Dim textContent As String
    Dim lines As Variant
    Dim i As Long
    Dim dataArray As Variant
    Dim code As String
    Dim lastRow As Long
    Dim r As Long
    ' Target this worksheet
    Set wsTarget = Me
    
    ' === Step 1: Select CSV file ===
    Set fileDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fileDialog
        .Filters.Clear
        .Filters.Add "CSV Files", "*.csv"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        filePath = .SelectedItems(1)
    End With
    
    ' === Step 2: Read CSV with Shift-JIS ===
    Set stream = CreateObject("ADODB.Stream")
    With stream
        .Type = 2
        .Charset = "shift_jis"
        .Open
        .LoadFromFile filePath
        textContent = .ReadText
        .Close
    End With
    
    lines = Split(textContent, vbLf)
    
    ' === First: validate all data rows have exactly 7 columns ===
    Dim validRowCount As Long
    Dim lineNum As Long
    validRowCount = 0
    For lineNum = 0 To UBound(lines)
        If Trim(lines(lineNum)) <> "" Then
            dataArray = Split(lines(lineNum), ",")
            If UBound(dataArray) + 1 <> 7 Then
                MsgBox "CSV line " & (lineNum + 1) & " has " & (UBound(dataArray) + 1) & " columns. Expected 7.", vbExclamation
                Exit Sub
            End If
            validRowCount = validRowCount + 1
        End If
    Next lineNum
    
    If validRowCount = 0 Then
        MsgBox "No valid data in CSV.", vbExclamation
        Exit Sub
    End If
    
    ' === Clear all data rows before import ===
    lastRow = wsTarget.Cells(wsTarget.Rows.Count, "C").End(xlUp).Row
    If lastRow >= 7 Then
        wsTarget.Range("A7:P" & lastRow).ClearContents
    End If
    
    If UBound(lines) < 1 Then
        MsgBox "No data in CSV.", vbExclamation
        Exit Sub
    End If
    
    ' === Step 3: Collect CSV codes and data ===
    Dim csvData As Object
    Set csvData = CreateObject("Scripting.Dictionary")
    
    For i = 0 To UBound(lines)
        If Trim(lines(i)) = "" Then GoTo NextCsvLine
        dataArray = Split(lines(i), ",")
        If UBound(dataArray) >= 0 Then
            code = CleanCSVField(CStr(dataArray(0)))
            If code <> "" Then
                ' Use unique key: code + "_" + row index to avoid duplicate key error
                csvData.Add code & "_" & i, dataArray
            End If
        End If
NextCsvLine:
    Next i
    
    If csvData.Count = 0 Then
        MsgBox "No valid code found.", vbExclamation
        Exit Sub
    End If
    
    ' === Step 6: Write CSV data to next available row === 
    writeRow = 7
    
    For i = 0 To UBound(lines)
        If Trim(lines(i)) = "" Then GoTo NextLine
        
        dataArray = Split(lines(i), ",")
        
        ' CSV col 1 -> C column
        code = CleanCSVField(CStr(dataArray(0)))
        wsTarget.Cells(writeRow, 3).Value = code

        writeRow = writeRow + 1
NextLine:
    Next i
    
    MsgBox writeRow - 7 & " rows imported.", vbInformation
End Sub

Function CleanCSVField(ByVal field As Variant) As String
    If IsEmpty(field) Or IsNull(field) Then
        CleanCSVField = ""
        Exit Function
    End If
    
    Dim result As String
    result = Trim(CStr(field))
    
    If Len(result) >= 2 Then
        If Left(result, 1) = """" And Right(result, 1) = """" Then
            result = Mid(result, 2, Len(result) - 2)
            result = Replace(result, """""", """")
        End If
    End If
    CleanCSVField = result
End Function

Sub validateDetailData(ByVal ws As Worksheet, ByVal rowNum As Long)
    ' Check C column - must be 3-digit alphanumeric, required
    Dim cValue As String
    cValue = Trim(ws.Cells(rowNum, 3).Value)
    
    If cValue = "" Then
        ws.Cells(rowNum, 2).Value = "C column is required"
        Exit Sub
    End If
    
    If Len(cValue) <> 3 Then
        ws.Cells(rowNum, 2).Value = "C column must be 3 characters"
        Exit Sub
    End If
    
    Dim i As Long
    Dim ch As String
    For i = 1 To 3
        ch = Mid(cValue, i, 1)
        If Not ((ch >= "0" And ch <= "9") Or (ch >= "A" And ch <= "Z") Or (ch >= "a" And ch <= "z")) Then
            ws.Cells(rowNum, 2).Value = "C column must be alphanumeric"
            Exit Sub
        End If
    Next i
    
    ' Check D column - must be within 80 full-width characters, required
    Dim dValue As String
    dValue = Trim(ws.Cells(rowNum, 4).Value)
    
    If dValue = "" Then
        ws.Cells(rowNum, 2).Value = "D column is required"
        Exit Sub
    End If
    
    If Len(dValue) > 80 Then
        ws.Cells(rowNum, 2).Value = "D column must be within 80 characters"
        Exit Sub
    End If
    
    ' Check E column - must be within 80 full-width characters, required
    Dim eValue As String
    eValue = Trim(ws.Cells(rowNum, 5).Value)
    
    If eValue = "" Then
        ws.Cells(rowNum, 2).Value = "E column is required"
        Exit Sub
    End If
    
    If Len(eValue) > 80 Then
        ws.Cells(rowNum, 2).Value = "E column must be within 80 characters"
        Exit Sub
    End If
    
    ' Check F column - must be within 80 full-width characters, optional
    Dim fValue As String
    fValue = Trim(ws.Cells(rowNum, 6).Value)
    If fValue <> "" And Len(fValue) > 80 Then
        ws.Cells(rowNum, 2).Value = "F column must be within 80 characters"
        Exit Sub
    End If
    
    ' Check G column - must be within 80 full-width characters, optional
    Dim gValue As String
    gValue = Trim(ws.Cells(rowNum, 7).Value)
    If gValue <> "" And Len(gValue) > 80 Then
        ws.Cells(rowNum, 2).Value = "G column must be within 80 characters"
        Exit Sub
    End If
    
    ' Check I column - must be within 80 full-width characters, optional
    Dim iValue As String
    iValue = Trim(ws.Cells(rowNum, 9).Value)
    If iValue <> "" And Len(iValue) > 80 Then
        ws.Cells(rowNum, 2).Value = "I column must be within 80 characters"
        Exit Sub
    End If
    
    ' Check H column - 1 digit, 0 or 1, optional
    Dim hValue As String
    hValue = Trim(ws.Cells(rowNum, 8).Value)
    If hValue <> "" Then
        If Len(hValue) <> 1 Then
            ws.Cells(rowNum, 2).Value = "H column must be 1 digit"
            Exit Sub
        End If
        If hValue <> "0" And hValue <> "1" Then
            ws.Cells(rowNum, 2).Value = "H column must be 0 or 1"
            Exit Sub
        End If
    End If
    
    ' Validation passed
    ws.Cells(rowNum, 2).ClearContents
End Sub


' Button macro (Validate selected row)
Sub validateDetailDataButton()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim r As Long
    Dim errorCount As Long
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    If lastRow < 7 Then
        MsgBox "No data found.", vbExclamation
        Exit Sub
    End If
    
    errorCount = 0
    For r = 7 To lastRow
        Call validateDetailData(ws, r)
        If Trim(ws.Cells(r, 2).Value) <> "" Then
            errorCount = errorCount + 1
        End If
    Next r
    
    MsgBox "Validation complete. Errors: " & errorCount & ", ", vbInformation
End Sub

Sub ExportMasterDetailData()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    Dim lastDataRow As Long
    lastDataRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    If lastDataRow < 7 Then
        MsgBox "No data rows to output.", vbExclamation
        Exit Sub
    End If
    
    Dim savePath As String
    savePath = Application.GetSaveAsFilename( _
        FileFilter:="CSV Files (*.csv), *.csv", _
        Title:="Save CSV")
    
    If savePath = "False" Then Exit Sub
    If InStr(1, savePath, ".csv", vbTextCompare) = 0 Then
        savePath = savePath & ".csv"
    End If
    
    ' Build header from row 5 (columns C, G-P)
    Dim csvContent As String
    csvContent = Trim(ws.Cells(5, 3).Value)
    Dim j As Long
    For j = 7 To 16
        csvContent = csvContent & "," & Trim(ws.Cells(5, j).Value)
    Next j
    csvContent = csvContent & vbLf
    
    ' Row counter
    Dim rowCount As Long
    rowCount = 0
    
    ' Data: C,G,H,I,J,K,L,M,N,O,P (skip D,E,F)
    Dim r As Long
    For r = 7 To lastDataRow
        If Len(Trim(ws.Cells(r, 3).Value & "")) > 0 Then
            rowCount = rowCount + 1
            ' CSV col1 -> C column
            csvContent = csvContent & CleanCSVField(ws.Cells(r, 3).Value)
            ' CSV col2-11 -> I-R column
            For j = 9 To 18
                csvContent = csvContent & "," & CleanCSVField(ws.Cells(r, j).Value)
            Next j
            csvContent = csvContent & vbLf
        End If
    Next r
    
    ' Trim trailing empty lines
    Do While Right(csvContent, 1) = vbLf
        csvContent = Left(csvContent, Len(csvContent) - 1)
    Loop
    
    ' Write file
    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 2
    stream.Charset = "shift_jis"
    stream.Open
    stream.WriteText csvContent, 1
    stream.SaveToFile savePath, 2
    stream.Close
    
    MsgBox "CSV export completed. Total data rows: " & rowCount, vbInformation
End Sub