From 9338e4adbf7bb8e4c419212e55be6a9fe8c36a92 Mon Sep 17 00:00:00 2001 From: updsv7 Date: Mon, 13 Apr 2026 18:19:37 +0900 Subject: [PATCH] Update Z1 export to use common functions --- vba_code_common.txt | 90 +++++++++++++++++++++++++++++++++++++++ vba_code_kotsu_master.txt | 60 ++++++++++---------------- 2 files changed, 112 insertions(+), 38 deletions(-) diff --git a/vba_code_common.txt b/vba_code_common.txt index fc92493..125f148 100644 --- a/vba_code_common.txt +++ b/vba_code_common.txt @@ -110,3 +110,93 @@ Function ReadCSVFile(ByVal filePath As String) As Variant ReadCSVFile = Split(textContent, vbLf) End Function + +' ============================================================ +' Get save file path for CSV +' Returns: file path or "" if cancelled +' ============================================================ +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 + +' ============================================================ +' Write content to CSV file with Shift-JIS encoding +' ============================================================ +Sub WriteCSVFile(ByVal filePath As String, ByVal content As String) + Dim stream As Object + Set stream = CreateObject("ADODB.Stream") + With stream + .Type = 2 + .Charset = "shift_jis" + .Open + .WriteText content, 1 + .SaveToFile filePath, 2 + .Close + End With +End Sub + +' ============================================================ +' Build CSV content from worksheet +' Parameters: +' ws - worksheet +' startRow - data start row +' endRow - data end row +' dataColumns - array of column numbers to export +' Returns: CSV content string +' ============================================================ +Function BuildCSVContent(ByVal ws As Worksheet, ByVal startRow As Long, ByVal endRow As Long, ByRef dataColumns() As Long, Optional ByVal headerRow As Long = 0) As String + Dim csvContent As String + Dim r As Long + Dim col As Long + Dim firstCol As Boolean + + ' Build header if specified + If headerRow > 0 Then + For col = LBound(dataColumns) To UBound(dataColumns) + If col = LBound(dataColumns) Then + csvContent = Trim(ws.Cells(headerRow, dataColumns(col)).Value) + Else + csvContent = csvContent & "," & Trim(ws.Cells(headerRow, dataColumns(col)).Value) + End If + Next col + csvContent = csvContent & vbLf + End If + + ' Build data rows + For r = startRow To endRow + If Len(Trim(ws.Cells(r, dataColumns(LBound(dataColumns))).Value & "")) > 0 Then + firstCol = True + For col = LBound(dataColumns) To UBound(dataColumns) + If firstCol Then + csvContent = csvContent & CleanCSVField(ws.Cells(r, dataColumns(col)).Value) + firstCol = False + Else + csvContent = csvContent & "," & CleanCSVField(ws.Cells(r, dataColumns(col)).Value) + End If + Next col + csvContent = csvContent & vbLf + End If + Next r + + ' Trim trailing newlines + Do While Right(csvContent, 1) = vbLf + csvContent = Left(csvContent, Len(csvContent) - 1) + Loop + + BuildCSVContent = csvContent +End Function diff --git a/vba_code_kotsu_master.txt b/vba_code_kotsu_master.txt index 387a457..620813d 100644 --- a/vba_code_kotsu_master.txt +++ b/vba_code_kotsu_master.txt @@ -224,66 +224,50 @@ Sub Z1_ExportMasterDetailData() Dim ws As Worksheet Set ws = ActiveSheet + ' Get last data row Dim lastDataRow As Long - lastDataRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row + lastDataRow = GetLastDataRow(ws, 3) If lastDataRow < 7 Then MsgBox "No data rows to output.", vbExclamation Exit Sub End If + ' Get save path Dim savePath As String - savePath = Application.GetSaveAsFilename( _ - FileFilter:="CSV Files (*.csv), *.csv", _ - Title:="Save CSV") + savePath = GetSaveCSVPath() + If savePath = "" Then Exit Sub - If savePath = "False" Then Exit Sub - If InStr(1, savePath, ".csv", vbTextCompare) = 0 Then - savePath = savePath & ".csv" - End If + ' Define columns to export (C, I-R = 3, 9-18) + Dim dataColumns(0 To 9) As Long + dataColumns(0) = 3 + dataColumns(1) = 9 + dataColumns(2) = 10 + dataColumns(3) = 11 + dataColumns(4) = 12 + dataColumns(5) = 13 + dataColumns(6) = 14 + dataColumns(7) = 15 + dataColumns(8) = 16 + dataColumns(9) = 17 + dataColumns(10) = 18 - ' Build header from row 5 (columns C, G-P) + ' Build CSV content (with header from row 5) 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 + csvContent = BuildCSVContent(ws, 7, lastDataRow, dataColumns, 5) - ' Row counter + ' Count rows 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 + Call WriteCSVFile(savePath, csvContent) MsgBox "CSV export completed. Total data rows: " & rowCount, vbInformation End Sub \ No newline at end of file