Option Explicit
' Main procedure to convert column pairs to vertical format
Sub ConvertColumnPairsToVerticalXLSM()
' Declare all variables
Dim sourceFile As Variant
Dim wbSource As Workbook, wbTarget As Workbook
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim wsName As String
Dim i As Long, pairIndex As Long, rowOffset As Long
Dim fileName As String
Dim maxRow As Long
Dim targetPath As String
Dim startTime As Double
Dim processedCells As Long
' Define column pair mappings
Dim colPairs() As Variant
Dim pair1 As Variant, pair2 As Variant, pair3 As Variant, pair4 As Variant, pair5 As Variant
Dim pair6 As Variant, pair7 As Variant, pair8 As Variant, pair9 As Variant, pair10 As Variant, pair11 As Variant
pair1 = Array(Array(4, 5), "D:E")
pair2 = Array(Array(9, 10), "I:J")
pair3 = Array(Array(11, 12), "K:L")
pair4 = Array(Array(13, 14), "M:N")
pair5 = Array(Array(15, 16), "O:P")
pair6 = Array(Array(17, 18), "Q:R")
pair7 = Array(Array(19, 20), "S:T")
pair8 = Array(Array(21, 22), "U:V")
pair9 = Array(Array(23, 24), "W:X")
pair10 = Array(Array(25, 26), "Y:Z")
pair11 = Array(Array(27, 28), "AA:AB")
colPairs = Array(pair1, pair2, pair3, pair4, pair5, pair6, pair7, pair8, pair9, pair10, pair11)
' Start timer
startTime = Timer
processedCells = 0
' Step 1: Select source Excel file
sourceFile = Application.GetOpenFilename( _
FileFilter:="Excel Files (*.xlsx; *.xls; *.xlsm), *.xlsx; *.xls; *.xlsm", _
Title:="Select Source Excel File")
If sourceFile = False Then Exit Sub ' User canceled
' Step 2: Open selected workbook
Application.ScreenUpdating = False
Set wbSource = Workbooks.Open(sourceFile, ReadOnly:=True)
' Prompt for worksheet name
wsName = Application.InputBox("Enter worksheet name to process:", "Worksheet Selection", Type:=2)
If wsName = "" Or wsName = "False" Then
wbSource.Close False
Exit Sub
End If
On Error Resume Next
Set wsSource = wbSource.Sheets(wsName)
On Error GoTo 0
If wsSource Is Nothing Then
MsgBox "Worksheet '" & wsName & "' not found!", vbExclamation
wbSource.Close False
Exit Sub
End If
' Step 3: Determine maximum data row
maxRow = FindMaxDataRow(wsSource, colPairs)
If maxRow = 0 Then
MsgBox "No data found in specified columns", vbInformation
wbSource.Close False
Exit Sub
End If
' Step 4: Get output file name
fileName = 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
targetPath = Application.GetSaveAsFilename( _
InitialFileName:=fileName & ".xlsm", _
FileFilter:="Excel Macro-Enabled Workbook (*.xlsm), *.xlsm", _
Title:="Save Output File")
If targetPath = False Then ' User canceled
wbSource.Close False
Exit Sub
End If
' Step 5: Create new workbook
Set wbTarget = Workbooks.Add
Set wsTarget = wbTarget.Sheets(1)
wsTarget.Name = "OutputData"
' Step 6: Add headers
For i = LBound(colPairs) To UBound(colPairs)
wsTarget.Cells(1, i + 1).Value = "Column Pair " & (i + 1) & " (" & colPairs(i)(1) & ")"
wsTarget.Cells(1, i + 1).Font.Bold = True
wsTarget.Cells(1, i + 1).Interior.Color = RGB(200, 200, 255)
wsTarget.Cells(1, i + 1).HorizontalAlignment = xlCenter
Next i
' Step 7: Use arrays for better performance
Dim outputData() As Variant
Dim outputRows As Long
outputRows = maxRow * 2 ' Each column has 2 rows per data point
ReDim outputData(1 To outputRows, 1 To UBound(colPairs) + 1)
' Populate data array with type-safe assignments
For pairIndex = LBound(colPairs) To UBound(colPairs)
Dim columns As Variant
columns = colPairs(pairIndex)(0) ' Get column indices array
' Process each row for current column pair
For i = 1 To maxRow
' Calculate target row position
rowOffset = (i - 1) * 2
' First column data
outputData(rowOffset + 1, pairIndex + 1) = GetCellValue(wsSource, i, columns(0))
processedCells = processedCells + 1
' Second column data
outputData(rowOffset + 2, pairIndex + 1) = GetCellValue(wsSource, i, columns(1))
processedCells = processedCells + 1
Next i
Next pairIndex
' Step 8: Write data to worksheet in bulk
If outputRows > 0 Then
wsTarget.Range("A2").Resize(outputRows, UBound(colPairs) + 1).Value = outputData
End If
' Step 9: Apply formatting
ApplyFormatting wsTarget, maxRow * 2, UBound(colPairs) + 1
' Step 10: Create summary sheet
CreateSummarySheet wbTarget, wbSource.FullName, wsName, startTime, processedCells, maxRow, UBound(colPairs) + 1
' Step 11: Save workbook
Application.DisplayAlerts = False
wbTarget.SaveAs fileName:=targetPath, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
' Step 12: Cleanup
wbSource.Close False
Set wsSource = Nothing
Set wbSource = Nothing
' Add VBA code to the workbook
If Not AddVbaCodeToWorkbook(wbTarget) Then
MsgBox "Unable to add macro code, but report has been saved.", vbExclamation
End If
' Save again with macros
wbTarget.Save
' Completion message
MsgBox "Report generated successfully!" & vbCrLf & _
"Saved to: " & targetPath & vbCrLf & _
"Cells processed: " & Format(processedCells, "#,##0") & vbCrLf & _
"Time taken: " & Format(Timer - startTime, "0.00") & " seconds", _
vbInformation, "Complete"
Application.ScreenUpdating = True
End Sub
' Safely get cell value with proper type handling
Function GetCellValue(ws As Worksheet, row As Long, col As Long) As Variant
' Handle potential errors
On Error Resume Next
' Check if row is beyond data range
If row > ws.Cells(ws.Rows.Count, col).End(xlUp).row Then
GetCellValue = ""
Exit Function
End If
Dim cellValue As Variant
cellValue = ws.Cells(row, col).Value
' Handle empty cells
If IsEmpty(cellValue) Then
GetCellValue = ""
Exit Function
End If
' Handle error values
If IsError(cellValue) Then
GetCellValue = "Error: " & CStr(cellValue)
Exit Function
End If
' Format dates consistently
If IsDate(cellValue) Then
GetCellValue = Format(cellValue, "yyyy-mm-dd")
Exit Function
End If
' Handle large numbers to prevent scientific notation
If IsNumeric(cellValue) Then
If Abs(cellValue) > 1E+15 Then
GetCellValue = "'" & CStr(cellValue)
Exit Function
End If
End If
' Default case
GetCellValue = cellValue
End Function
' Apply consistent formatting to output
Sub ApplyFormatting(ws As Worksheet, dataRows As Long, colCount As Long)
' Define the data range
Dim rng As Range
Set rng = ws.Range("A2").Resize(dataRows, colCount)
' Set text properties
With rng
.WrapText = True
.VerticalAlignment = xlTop
End With
' Apply alternating row colors
Dim rowIdx As Long
For rowIdx = 2 To dataRows + 1
If rowIdx Mod 2 = 0 Then
ws.Rows(rowIdx).Interior.Color = RGB(240, 240, 240) ' Light gray
Else
ws.Rows(rowIdx).Interior.Color = RGB(255, 255, 255) ' White
End If
Next rowIdx
' Auto-fit columns for optimal width
ws.columns.AutoFit
' Add borders to data area
With rng.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(150, 150, 150)
End With
' Freeze header row for easy scrolling
ws.Activate
ws.Range("A2").Select
ActiveWindow.FreezePanes = True
End Sub
' Find the maximum row with data across all column pairs
Function FindMaxDataRow(ws As Worksheet, colPairs As Variant) As Long
Dim maxRow As Long
Dim i As Long
Dim columns As Variant
maxRow = 0
For i = LBound(colPairs) To UBound(colPairs)
columns = colPairs(i)(0) ' Get column indices array
' Check first column
maxRow = Application.WorksheetFunction.Max(maxRow, _
ws.Cells(ws.Rows.Count, columns(0)).End(xlUp).row)
' Check second column
maxRow = Application.WorksheetFunction.Max(maxRow, _
ws.Cells(ws.Rows.Count, columns(1)).End(xlUp).row)
Next i
FindMaxDataRow = maxRow
End Function
' Create summary sheet with report details
Sub CreateSummarySheet(wb As Workbook, sourcePath As String, sheetName As String, _
startTime As Double, cellCount As Long, maxRow As Long, pairCount As Long)
' Add new worksheet
Dim ws As Worksheet
Set ws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
ws.Name = "ReportSummary"
' Create title
With ws.Range("A1")
.Value = "Data Conversion Report Summary"
.Font.Size = 16
.Font.Bold = True
.Interior.Color = RGB(180, 180, 255)
End With
' Prepare report details
Dim details As Variant
details = Array( _
Array("Source file:", sourcePath), _
Array("Worksheet:", sheetName), _
Array("Generated at:", Format(Now, "yyyy-mm-dd hh:mm:ss")), _
Array("Column pairs processed:", pairCount), _
Array("Rows processed:", maxRow), _
Array("Cells processed:", Format(cellCount, "#,##0")), _
Array("Time taken:", Format(Timer - startTime, "0.00") & " seconds"))
' Write details to worksheet
Dim i As Long
For i = 0 To UBound(details)
ws.Cells(i + 3, 1).Value = details(i)(0)
ws.Cells(i + 3, 1).Font.Bold = True
ws.Cells(i + 3, 2).Value = details(i)(1)
Next i
' Add navigation buttons
Dim btn As Button
' View Data button
Set btn = ws.Buttons.Add(100, 100, 120, 30)
With btn
.Caption = "View Data"
.OnAction = "GoToOutputSheet"
.Name = "btnViewData"
End With
' Regenerate button
Set btn = ws.Buttons.Add(100, 140, 120, 30)
With btn
.Caption = "Regenerate"
.OnAction = "RefreshReport"
.Name = "btnRefresh"
End With
' Close Report button
Set btn = ws.Buttons.Add(100, 180, 120, 30)
With btn
.Caption = "Close Report"
.OnAction = "CloseReport"
.Name = "btnClose"
End With
' Format summary sheet
With ws.Range("A3:B" & 3 + UBound(details))
.Borders.Weight = xlThin
.columns.AutoFit
End With
End Sub
' Add VBA code to the workbook for button functionality
Function AddVbaCodeToWorkbook(wb As Workbook) As Boolean
On Error GoTo ErrorHandler
Dim vbProj As Object
Dim vbComp As Object
Dim codeLines As String
Set vbProj = wb.VBProject
Set vbComp = vbProj.VBComponents.Add(1) ' Create standard module
' Add GoToOutputSheet procedure
codeLines = "Sub GoToOutputSheet()" & vbCrLf & _
" On Error Resume Next" & vbCrLf & _
" Sheets(""OutputData"").Activate" & vbCrLf & _
" If Err.Number <> 0 Then" & vbCrLf & _
" MsgBox ""'OutputData' worksheet not found!"", vbExclamation" & vbCrLf & _
" End If" & vbCrLf & _
"End Sub"
vbComp.CodeModule.AddFromString codeLines
' Add RefreshReport procedure
codeLines = "Sub RefreshReport()" & vbCrLf & _
" MsgBox ""To regenerate this report, you need access to the original data file." & vbCrLf & _
"Please run the original macro to regenerate the report."", vbInformation" & vbCrLf & _
"End Sub"
vbComp.CodeModule.AddFromString codeLines
' Add CloseReport procedure
codeLines = "Sub CloseReport()" & vbCrLf & _
" ThisWorkbook.Close SaveChanges:=False" & vbCrLf & _
"End Sub"
vbComp.CodeModule.AddFromString codeLines
AddVbaCodeToWorkbook = True
Exit Function
ErrorHandler:
AddVbaCodeToWorkbook = False
End Function
修正byref错误