Option Explicit
Private currentPairIndex As Long
Private currentRow As Long
Private currentColumn As Long
Private currentOperation As String
Private targetPath As String
Private sourceFilePath As String
Private dataPoints As Long
Private maxRow As Long
Sub ConvertColumnPairsToCSV()
On Error GoTo ErrorHandler
' Initialize variables
Dim sourceFile As Variant
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim fileName As String
Dim startTime As Double
Dim processedCells As Long
Dim i As Long, pairIndex As Long, rowIndex As Long
' Reset tracking variables
ResetTrackingVariables
' Start timer
startTime = Timer
processedCells = 0
dataPoints = 0
' Define column pairs
Dim colPairs() As Variant
colPairs = Array( _
Array(Array(4, 5), "D:E"), _
Array(Array(9, 10), "I:J"), _
Array(Array(11, 12), "K:L"), _
Array(Array(13, 14), "M:N"), _
Array(Array(15, 16), "O:P"), _
Array(Array(17, 18), "Q:R"), _
Array(Array(19, 20), "S:T"), _
Array(Array(21, 22), "U:V"), _
Array(Array(23, 24), "W:X"), _
Array(Array(25, 26), "Y:Z"), _
Array(Array(27, 28), "AA:AB") _
)
' Step 1: Select source file
currentOperation = "Selecting source file"
sourceFile = Application.GetOpenFilename( _
FileFilter:="Excel Files (*.xlsx; *.xls; *.xlsm), *.xlsx; *.xls; *.xlsm", _
Title:="Select Source Excel File")
If VarType(sourceFile) = vbBoolean And sourceFile = False Then Exit Sub
sourceFilePath = CStr(sourceFile)
' Step 2: Open workbook
currentOperation = "Opening workbook"
Application.ScreenUpdating = False
Application.StatusBar = "Opening source file..."
Set wbSource = Workbooks.Open(sourceFile, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
' Step 3: Get worksheet
Set wsSource = SelectWorksheet(wbSource)
If wsSource Is Nothing Then
wbSource.Close False
Exit Sub
End If
' Step 4: Detect data in columns
currentOperation = "Detecting data in columns"
Application.StatusBar = "Scanning worksheet for data..."
' Enhanced data detection with detailed diagnostics
Dim hasData As Boolean
hasData = DetectDataInColumns(wsSource, colPairs)
' If no data found, show detailed diagnostics
If Not hasData Then
wbSource.Close False
ShowNoDataDiagnostics wsSource, colPairs, sourceFilePath
Exit Sub
End If
' Step 5: Get output file details
currentOperation = "Getting output file details"
fileName = CStr(Application.InputBox("Enter output file name (without extension):", "File Name", "OP_Report", Type:=2))
If fileName = "" Or fileName = "False" Then
wbSource.Close False
Exit Sub
End If
' Get save path
Dim saveDialogResult As Variant
saveDialogResult = GetSavePath(fileName)
If VarType(saveDialogResult) = vbBoolean And saveDialogResult = False Then
wbSource.Close False
Application.StatusBar = False
Exit Sub
End If
targetPath = CStr(saveDialogResult)
' Step 6: Process and save data
currentOperation = "Processing and saving data"
If ProcessAndSaveData(wsSource, colPairs, targetPath, processedCells) Then
' Completion message
MsgBox "CSV file generated successfully!" & vbCrLf & _
"Saved to: " & targetPath & vbCrLf & _
"Data points found: " & Format(dataPoints, "#,##0") & vbCrLf & _
"Cells processed: " & Format(processedCells, "#,##0") & vbCrLf & _
"Time taken: " & Format(Timer - startTime, "0.00") & " seconds", _
vbInformation, "Process Complete"
End If
' Cleanup
Cleanup wbSource
ExitSub:
Application.StatusBar = False
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
HandleError
GoTo ExitSub
End Sub
' =========================================================
' Core Functions
' =========================================================
Private Sub ResetTrackingVariables()
currentPairIndex = -1
currentRow = -1
currentColumn = -1
currentOperation = "Initialization"
targetPath = ""
sourceFilePath = ""
dataPoints = 0
maxRow = 0
End Sub
Private Function SelectWorksheet(wb As Workbook) As Worksheet
On Error Resume Next
currentOperation = "Selecting worksheet"
Dim wsName As String
wsName = CStr(Application.InputBox("Enter the worksheet name to process:", "Worksheet Selection", Type:=2))
If wsName = "" Or wsName = "False" Then
Set SelectWorksheet = Nothing
Exit Function
End If
Set SelectWorksheet = wb.Sheets(wsName)
If SelectWorksheet Is Nothing Then
MsgBox "Worksheet '" & wsName & "' not found!", vbExclamation
End If
End Function
Private Function DetectDataInColumns(ws As Worksheet, colPairs As Variant) As Boolean
' Check source columns B and C
Dim col As Long
Dim cellValue As String
' Check column B
For col = 2 To 3
currentColumn = col
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).row
For currentRow = 1 To lastRow
cellValue = GetCellValue(ws, currentRow, col)
If Len(Trim(cellValue)) > 0 Then
dataPoints = dataPoints + 1
DetectDataInColumns = True
End If
Next currentRow
Next col
' Check column pairs
Dim i As Long, j As Long
For i = LBound(colPairs) To UBound(colPairs)
Dim pair As Variant
pair = colPairs(i)
Dim columns As Variant
columns = pair(0)
For j = LBound(columns) To UBound(columns)
col = SafeConvertToLong(columns(j))
currentColumn = col
lastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).row
For currentRow = 1 To lastRow
cellValue = GetCellValue(ws, currentRow, col)
If Len(Trim(cellValue)) > 0 Then
dataPoints = dataPoints + 1
DetectDataInColumns = True
' Update maxRow for later processing
If currentRow > maxRow Then maxRow = currentRow
End If
Next currentRow
Next j
Next i
' If no data found, scan entire worksheet
If Not DetectDataInColumns Then
DetectDataInColumns = ScanEntireWorksheet(ws)
End If
End Function
Private Function ScanEntireWorksheet(ws As Worksheet) As Boolean
' Last resort: scan entire worksheet for any data
On Error Resume Next
Dim usedRange As Range
Set usedRange = ws.usedRange
If usedRange Is Nothing Then
ScanEntireWorksheet = False
Exit Function
End If
Dim cell As Range
For Each cell In usedRange
If Len(Trim(cell.value)) > 0 Then
dataPoints = dataPoints + 1
ScanEntireWorksheet = True
End If
Next cell
End Function
Private Function GetSavePath(fileName As String) As Variant
currentOperation = "Getting save path"
GetSavePath = Application.GetSaveAsFilename( _
InitialFileName:=fileName & ".csv", _
FileFilter:="CSV Files (*.csv), *.csv", _
Title:="Save CSV File")
End Function
Private Function ProcessAndSaveData( _
ws As Worksheet, _
colPairs As Variant, _
savePath As String, _
ByRef processedCells As Long) As Boolean
On Error GoTo ErrorHandler
' Create UTF-8 encoded CSV
currentOperation = "Creating CSV file"
Application.StatusBar = "Creating CSV file..."
Dim stream As Object
Set stream = CreateObject("ADODB.Stream")
stream.Charset = "UTF-8"
stream.Open
stream.WriteText ChrW(&HFEFF) ' UTF-8 BOM
' Create header
Dim headerLine As String
headerLine = "Source B,Source C"
Dim i As Long
For i = 0 To UBound(colPairs)
headerLine = headerLine & ",Column Pair " & (i + 1) & " (" & colPairs(i)(1) & ")"
Next i
stream.WriteText headerLine & vbCrLf
' Process data row by row
Dim columns As Variant
Dim col1 As Long, col2 As Long
Dim sourceBValue As String, sourceCValue As String
Dim outputLine1 As String, outputLine2 As String
Dim formattedValue As String
Dim dataFound As Boolean
dataFound = False
' Use maxRow from detection or calculate if needed
If maxRow = 0 Then
On Error Resume Next
maxRow = ws.usedRange.Rows.Count
If Err.Number <> 0 Then maxRow = 1000 ' Default max
On Error GoTo ErrorHandler
End If
For currentRow = 1 To maxRow
' Get values from columns B and C
sourceBValue = GetFormattedCellValue(ws, currentRow, 2)
sourceCValue = GetFormattedCellValue(ws, currentRow, 3)
outputLine1 = sourceBValue & "," & sourceCValue
outputLine2 = sourceBValue & "," & sourceCValue
Dim hasDataInRow As Boolean
hasDataInRow = (Len(Trim(sourceBValue)) > 0) Or (Len(Trim(sourceCValue)) > 0)
' Process each column pair
For currentPairIndex = 0 To UBound(colPairs)
columns = colPairs(currentPairIndex)(0)
col1 = SafeConvertToLong(columns(0))
col2 = SafeConvertToLong(columns(1))
' Process first column
currentColumn = col1
formattedValue = GetFormattedCellValue(ws, currentRow, col1)
outputLine1 = outputLine1 & "," & formattedValue
' Process second column
currentColumn = col2
formattedValue = GetFormattedCellValue(ws, currentRow, col2)
outputLine2 = outputLine2 & "," & formattedValue
If Not hasDataInRow Then
hasDataInRow = (Len(Trim(formattedValue)) > 0)
End If
processedCells = processedCells + 2
Next currentPairIndex
If hasDataInRow Then
stream.WriteText outputLine1 & vbCrLf
stream.WriteText outputLine2 & vbCrLf
dataFound = True
End If
Next currentRow
' Final check for data
If Not dataFound Then
stream.Close
Set stream = Nothing
ShowNoDataDiagnostics ws, colPairs, sourceFilePath
ProcessAndSaveData = False
Exit Function
End If
' Save file
currentOperation = "Saving CSV file"
Application.StatusBar = "Saving CSV file..."
SaveStreamToFile stream, savePath
stream.Close
Set stream = Nothing
ProcessAndSaveData = True
Exit Function
ErrorHandler:
HandleError
On Error Resume Next
If Not stream Is Nothing Then
If stream.State = 1 Then stream.Close
Set stream = Nothing
End If
ProcessAndSaveData = False
End Function
Private Sub SaveStreamToFile(stream As Object, savePath As String)
Dim saveAttempt As Integer
Dim saveSuccessful As Boolean
saveSuccessful = False
For saveAttempt = 1 To 3
On Error Resume Next
stream.SaveToFile savePath, 2
If Err.Number = 0 Then
saveSuccessful = True
Exit For
Else
Application.Wait Now + TimeValue("00:00:00.5")
Err.Clear
End If
Next saveAttempt
On Error GoTo 0
If Not saveSuccessful Then
Err.Raise 3004, "SaveToFile", "Failed to save file after 3 attempts. Please check file permissions or if file is open."
End If
End Sub
' =========================================================
' Diagnostic Functions
' =========================================================
Private Sub ShowNoDataDiagnostics(ws As Worksheet, colPairs As Variant, filePath As String)
Dim msg As String
msg = "No data found in any of the specified columns." & vbCrLf & vbCrLf
msg = msg & "Detailed Diagnostics:" & vbCrLf
msg = msg & "--------------------------------------------------" & vbCrLf
msg = msg & "File Path: " & filePath & vbCrLf
msg = msg & "Worksheet: " & ws.Name & vbCrLf & vbCrLf
' Worksheet metrics
On Error Resume Next
msg = msg & "Worksheet Metrics:" & vbCrLf
msg = msg & "- Total Rows: " & Format(ws.usedRange.Rows.Count, "#,##0") & vbCrLf
msg = msg & "- Total Columns: " & Format(ws.usedRange.columns.Count, "#,##0") & vbCrLf
msg = msg & "- Total Cells: " & Format(ws.usedRange.Cells.Count, "#,##0") & vbCrLf
msg = msg & "- Data Points Found: " & Format(dataPoints, "#,##0") & vbCrLf & vbCrLf
' Column analysis
msg = msg & "Column Analysis:" & vbCrLf
msg = msg & "Columns Checked:" & vbCrLf
msg = msg & "- B (Source)" & vbCrLf
msg = msg & "- C (Source)" & vbCrLf
Dim i As Long, j As Long
For i = 0 To UBound(colPairs)
Dim cols As Variant
cols = colPairs(i)(0)
Dim desc As String
desc = colPairs(i)(1)
msg = msg & "- " & desc & " (Pair " & (i + 1) & ")" & vbCrLf
Next i
' Data presence in columns
msg = msg & vbCrLf & "Data Presence in Key Columns:" & vbCrLf
msg = msg & CheckColumnForData(ws, "B (Source)", 2)
msg = msg & CheckColumnForData(ws, "C (Source)", 3)
For i = 0 To UBound(colPairs)
Dim pair As Variant
pair = colPairs(i)
Dim pairCols As Variant
pairCols = pair(0)
Dim pairDesc As String
pairDesc = pair(1)
For j = LBound(pairCols) To UBound(pairCols)
msg = msg & CheckColumnForData(ws, pairDesc & " - Col " & pairCols(j), pairCols(j))
Next j
Next i
' Suggested solutions
msg = msg & vbCrLf & "Possible Solutions:" & vbCrLf
msg = msg & "1. Verify the correct worksheet is selected" & vbCrLf
msg = msg & "2. Check if data is in different columns than specified" & vbCrLf
msg = msg & "3. Ensure data isn't hidden by filters or grouping" & vbCrLf
msg = msg & "4. Confirm the file contains actual data (not just formulas)" & vbCrLf
msg = msg & "5. Try selecting a different file or worksheet" & vbCrLf
msg = msg & "6. Check for leading/trailing spaces with TRIM()" & vbCrLf
' Display detailed message
CreateDiagnosticForm msg
End Sub
Private Function CheckColumnForData(ws As Worksheet, colDesc As String, colNum As Long) As String
On Error Resume Next
Dim result As String
result = colDesc & ": "
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, colNum).End(xlUp).row
If lastRow = 1 And IsEmpty(ws.Cells(1, colNum)) Then
result = result & "NO DATA" & vbCrLf
Else
Dim dataCount As Long
dataCount = 0
Dim i As Long
For i = 1 To lastRow
If Not IsEmpty(ws.Cells(i, colNum)) Then
dataCount = dataCount + 1
End If
Next i
If dataCount > 0 Then
result = result & Format(dataCount, "#,##0") & " data points" & vbCrLf
Else
result = result & "NO DATA (cells appear empty)" & vbCrLf
End If
End If
CheckColumnForData = result
End Function
修正错误, 函数没定义
最新发布