删除 vba_all_in_one.bas
This commit is contained in:
@@ -1,336 +0,0 @@
|
||||
' ============================================================
|
||||
' 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(ByRef 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 ReadCSVFile(ByVal filePath As String) 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 = "shift_jis"
|
||||
.Open
|
||||
.LoadFromFile filePath
|
||||
textContent = .ReadText
|
||||
.Close
|
||||
End With
|
||||
|
||||
ReadCSVFile = Split(textContent, vbLf)
|
||||
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, 1
|
||||
.SaveToFile filePath, 2
|
||||
.Close
|
||||
End With
|
||||
End Sub
|
||||
|
||||
' ============================================================
|
||||
' Z1 Specific Functions
|
||||
' ============================================================
|
||||
|
||||
Sub Z1_ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long)
|
||||
ws.Range(ws.Cells(rowNum, 4), ws.Cells(rowNum, 15)).ClearContents
|
||||
ws.Cells(rowNum, 2).ClearContents
|
||||
End Sub
|
||||
|
||||
Sub Z1_ImportMasterDetailData()
|
||||
Dim filePath As String
|
||||
Dim wsTarget As Worksheet
|
||||
Dim lines As Variant
|
||||
Dim i As Long
|
||||
Dim dataArray As Variant
|
||||
Dim writeRow As Long
|
||||
|
||||
Set wsTarget = Me
|
||||
|
||||
filePath = SelectCSVFile()
|
||||
If filePath = "" Then Exit Sub
|
||||
|
||||
lines = ReadCSVFile(filePath)
|
||||
|
||||
If Not ValidateCSVColumnCount(lines, 7) Then Exit Sub
|
||||
|
||||
Call ClearDataRows(wsTarget, 7, 3)
|
||||
|
||||
writeRow = 7
|
||||
|
||||
For i = 0 To UBound(lines)
|
||||
If Trim(lines(i)) <> "" Then
|
||||
dataArray = Split(lines(i), ",")
|
||||
|
||||
wsTarget.Cells(writeRow, 3).Value = CleanCSVField(CStr(dataArray(0)))
|
||||
wsTarget.Cells(writeRow, 4).Value = CleanCSVField(CStr(dataArray(1)))
|
||||
wsTarget.Cells(writeRow, 5).Value = CleanCSVField(CStr(dataArray(2)))
|
||||
wsTarget.Cells(writeRow, 6).Value = CleanCSVField(CStr(dataArray(3)))
|
||||
wsTarget.Cells(writeRow, 7).Value = CleanCSVField(CStr(dataArray(4)))
|
||||
wsTarget.Cells(writeRow, 8).Value = CleanCSVField(CStr(dataArray(5)))
|
||||
wsTarget.Cells(writeRow, 9).Value = CleanCSVField(CStr(dataArray(6)))
|
||||
|
||||
writeRow = writeRow + 1
|
||||
End If
|
||||
Next i
|
||||
|
||||
MsgBox writeRow - 7 & " rows imported.", vbInformation
|
||||
End Sub
|
||||
|
||||
Sub Z1_ExportMasterDetailData()
|
||||
Dim ws As Worksheet
|
||||
Dim lastDataRow As Long
|
||||
Dim savePath As String
|
||||
Dim csvContent As String
|
||||
Dim r As Long
|
||||
Dim j As Long
|
||||
Dim rowCount As Long
|
||||
|
||||
Set ws = ActiveSheet
|
||||
|
||||
lastDataRow = GetLastDataRow(ws, 3)
|
||||
|
||||
If lastDataRow < 7 Then
|
||||
MsgBox "No data rows to output.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
savePath = GetSaveCSVPath()
|
||||
If savePath = "" Then Exit Sub
|
||||
|
||||
csvContent = Trim(ws.Cells(5, 3).Value)
|
||||
For j = 9 To 18
|
||||
csvContent = csvContent & "," & Trim(ws.Cells(5, j).Value)
|
||||
Next j
|
||||
csvContent = csvContent & vbLf
|
||||
|
||||
rowCount = 0
|
||||
For r = 7 To lastDataRow
|
||||
If Len(Trim(ws.Cells(r, 3).Value & "")) > 0 Then
|
||||
rowCount = rowCount + 1
|
||||
csvContent = csvContent & CleanCSVField(ws.Cells(r, 3).Value)
|
||||
For j = 9 To 18
|
||||
csvContent = csvContent & "," & CleanCSVField(ws.Cells(r, j).Value)
|
||||
Next j
|
||||
csvContent = csvContent & vbLf
|
||||
End If
|
||||
Next r
|
||||
|
||||
Do While Right(csvContent, 1) = vbLf
|
||||
csvContent = Left(csvContent, Len(csvContent) - 1)
|
||||
Loop
|
||||
|
||||
Call WriteCSVFile(savePath, csvContent)
|
||||
|
||||
MsgBox "CSV export completed. Total data rows: " & rowCount, vbInformation
|
||||
End Sub
|
||||
|
||||
Sub Z1_validateDetailData(ByVal ws As Worksheet, ByVal rowNum As Long)
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
ws.Cells(rowNum, 2).ClearContents
|
||||
End Sub
|
||||
|
||||
Sub Z1_validateDetailDataButton()
|
||||
Dim ws As Worksheet
|
||||
Dim lastRow As Long
|
||||
Dim r As Long
|
||||
Dim errorCount As Long
|
||||
|
||||
Set ws = ActiveSheet
|
||||
lastRow = GetLastDataRow(ws, 3)
|
||||
|
||||
If lastRow < 7 Then
|
||||
MsgBox "No data found.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
errorCount = 0
|
||||
For r = 7 To lastRow
|
||||
Call Z1_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
|
||||
Reference in New Issue
Block a user