|
|
Sub SortRowsAndCopy()
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim lastRow As Long, i As Long, j As Long
Dim dataRange As Range, sortedData As Variant
Dim colCount As Integer
' 设置源工作表
Set wsSource = ThisWorkbook.Sheets("Sheet1")
' 检查Sheet2是否存在，如果不存在则创建
On Error Resume Next
Set wsTarget = ThisWorkbook.Sheets("Sheet2")
On Error GoTo 0
If wsTarget Is Nothing Then
Set wsTarget = ThisWorkbook.Sheets.Add(After:=wsSource)
wsTarget.Name = "Sheet2"
End If
' 清空目标工作表以便存储新数据
wsTarget.Cells.Clear
' 复制标题行到Sheet2
wsSource.Rows(1).Copy Destination:=wsTarget.Rows(1)
' 找到源工作表的最后一行
lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
' 遍历源工作表的每一行（跳过第一行）
For i = 2 To lastRow
' 确定当前行的数据范围
Set dataRange = wsSource.Cells(i, 1).Resize(1, wsSource.Cells(i, wsSource.Columns.Count).End(xlToLeft).Column)
colCount = dataRange.Columns.Count
' 复制数据到数组并去除空值
Dim dataArray() As Variant
ReDim dataArray(1 To colCount)
Dim index As Integer
index = 0
For j = 1 To colCount
If Not IsEmpty(dataRange.Cells(1, j).Value) Then
index = index + 1
dataArray(index) = dataRange.Cells(1, j).Value
End If
Next j
ReDim Preserve dataArray(1 To index)
' 对数组进行快速排序
QuickSort dataArray, LBound(dataArray), UBound(dataArray)
' 将排序后的数据写入目标工作表
For j = 1 To index
wsTarget.Cells(i, j).Value = dataArray(j)
Next j
Next i
' 释放对象
Set wsSource = Nothing
Set wsTarget = Nothing
End Sub
' 快速排序函数
Private Sub QuickSort(arr() As Variant, low As Long, high As Long)
If low < high Then
Dim pi As Long
pi = Partition(arr, low, high)
QuickSort arr, low, pi - 1
QuickSort arr, pi + 1, high
End If
End Sub
' 分区函数
Private Function Partition(arr() As Variant, low As Long, high As Long) As Long
Dim pivot As Variant
pivot = arr(high)
Dim i As Long
i = (low - 1)
Dim temp As Variant
For j = low To high - 1
If arr(j) < pivot Then
i = i + 1
temp = arr(i)
arr(i) = arr(j)
arr(j) = temp
End If
Next j
temp = arr(i + 1)
arr(i + 1) = arr(high)
arr(high) = temp
Partition = (i + 1)
End Function
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-6-19 15:00
楼主
