Files
vba/vba_code_common.bas
2026-04-13 20:03:47 +09:00

185 lines
5.1 KiB
QBasic

' ============================================================
' Common Functions
' ============================================================
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
Function ValidateCSVColumnCount(ByVal lines As Variant, ByVal expectedColumns As Long) As Boolean
ValidateCSVColumnCount = True
Dim lineNum As Long
Dim dataArray As Variant
Dim validRowCount As Long
validRowCount = 0
For lineNum = 0 To UBound(lines)
If Trim(lines(lineNum)) <> "" Then
dataArray = Split(lines(lineNum), ",")
If UBound(dataArray) + 1 <> expectedColumns Then
MsgBox "CSV line " & (lineNum + 1) & " has " & (UBound(dataArray) + 1) & " columns. Expected " & expectedColumns & ".", vbExclamation
ValidateCSVColumnCount = False
Exit Function
End If
validRowCount = validRowCount + 1
End If
Next lineNum
If validRowCount = 0 Then
MsgBox "No valid data in CSV.", vbExclamation
ValidateCSVColumnCount = False
End If
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
Sub ClearDataRows(ByVal ws As Worksheet, ByVal startRow As Long, ByVal columnNum As Long)
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row
If lastRow >= startRow Then
ws.Range(ws.Cells(startRow, 1), ws.Cells(lastRow, 20)).ClearContents
End If
End Sub
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
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
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, 0
.SaveToFile filePath, 2
.Close
End With
End Sub
Function ReadCSVFile(ByVal filePath As String, Optional ByVal charset As String = "shift_jis") As Variant
If filePath = "" Then
ReadCSVFile = Array()
Exit Function
End If
Dim stream As Object
Dim textContent As String
Set stream = CreateObject("ADODB.Stream")
With stream
.Type = 2
.Charset = charset
.Open
.LoadFromFile filePath
textContent = .ReadText
.Close
End With
ReadCSVFile = Split(textContent, vbLf)
End Function
Sub SortDataRows(Optional ByVal sortColumn As Long = 3)
Dim ws As Worksheet
Dim lastRow As Long
Dim startRow As Long
Dim sortOrder As Long
Set ws = ActiveSheet
startRow = 7
lastRow = GetLastDataRow(ws, sortColumn)
If lastRow < startRow Then
MsgBox "No data to sort.", vbExclamation
Exit Sub
End If
' Determine sort order based on first row's current state
Dim currentFirst As String
Dim nextFirst As String
currentFirst = Trim(ws.Cells(startRow, sortColumn).Value)
nextFirst = Trim(ws.Cells(startRow + 1, sortColumn).Value)
If currentFirst <> "" And nextFirst <> "" Then
If currentFirst > nextFirst Then
sortOrder = xlAscending
Else
sortOrder = xlDescending
End If
Else
sortOrder = xlAscending
End If
ws.Range(ws.Cells(startRow, 1), ws.Cells(lastRow, 20)).Sort _
Key1:=ws.Cells(startRow, sortColumn), _
Order1:=sortOrder, _
Header:=xlNo
End Sub
Sub ToggleAutoFilter(Optional ByVal filterRow As Long = 6)
Dim ws As Worksheet
Set ws = ActiveSheet
' Check if auto filter is already on
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
Else
If filterRow >= 1 Then
ws.Rows(filterRow).AutoFilter
End If
End If
End Sub