📄 -
字号:
VERSION 5.00
Object = "{DD44C0E7-B2CF-11D1-8DD3-444553540000}#1.0#0"; "cell32.ocx"
Begin VB.Form frm_sort
BorderStyle = 3 'Fixed Dialog
Caption = "排序"
ClientHeight = 5040
ClientLeft = 45
ClientTop = 330
ClientWidth = 6990
Icon = "数据排序.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5040
ScaleWidth = 6990
ShowInTaskbar = 0 'False
StartUpPosition = 1 'CenterOwner
Begin CELLLib.Cell Cell3
Height = 1815
Left = 165
TabIndex = 9
Top = 3000
Visible = 0 'False
Width = 5115
_Version = 65536
_ExtentX = 9022
_ExtentY = 3201
_StockProps = 0
End
Begin VB.CommandButton Command4
Caption = "还原"
Height = 375
Left = 5670
TabIndex = 8
Top = 3570
Width = 1095
End
Begin VB.CommandButton Command3
Caption = "升序排列"
Height = 375
Left = 5670
TabIndex = 7
Top = 3090
Width = 1095
End
Begin CELLLib.Cell Cell2
Height = 1995
Left = 240
TabIndex = 6
Top = 2040
Visible = 0 'False
Width = 4095
_Version = 65536
_ExtentX = 7223
_ExtentY = 3519
_StockProps = 0
End
Begin VB.Frame Frame1
Height = 1215
Left = 5550
TabIndex = 3
Top = 120
Width = 1335
Begin VB.OptionButton Option2
Caption = "按行排序"
Height = 375
Left = 120
TabIndex = 5
Top = 720
Width = 1095
End
Begin VB.OptionButton Option1
Caption = "按列排序"
Height = 375
Left = 120
TabIndex = 4
Top = 240
Value = -1 'True
Width = 1095
End
End
Begin VB.CommandButton Command2
Caption = "取消(&C)"
Height = 375
Left = 5670
TabIndex = 2
Top = 4530
Width = 1095
End
Begin VB.CommandButton Command1
Caption = "确定(&0)"
Height = 375
Left = 5670
TabIndex = 1
Top = 4050
Width = 1095
End
Begin CELLLib.Cell Cell1
Height = 4815
Left = 90
TabIndex = 0
Top = 90
Width = 5355
_Version = 65536
_ExtentX = 9446
_ExtentY = 8493
_StockProps = 0
PageLabelVisible= 0 'False
End
End
Attribute VB_Name = "frm_sort"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'***********************************************
'* 模 块 名 称 :数据排序
'* 功 能 描 述 :
'* 程序员姓名 :奚俊峰
'* 最后修改人 :奚俊峰
'* 最后修改时间:2002/01/21
'***********************************************
Option Explicit
Private ml_col_begin, ml_row_begin, ml_col_end, ml_row_end
'true为升序，false为降序
Public mb_sort As Boolean
Private Sub mf_sort(ByVal ls_type As String) '排序
Dim lavar_data(), ls_formula As String, lvar_data
Dim ll_col As Long, ll_row As Long '分别代表当前排序选中的行（按行排序）、列（按列排序）
Dim lvar_data1, ll_data2 As Long '中间变量，用于交换是存放值
Dim i As Long, j As Long, lb_exchange As Boolean '判断是否交换
lb_exchange = False
'***************************************按列排序************************************
If ls_type = "col" Then
ReDim lavar_data(ml_row_end - ml_row_begin + 1, 2)
ll_col = Cell1.DoGetCurrentCol
'以下代码把选中的列的数据放入二维数组中
'数组内容：1。 数据，2。数据所在行
For i = 0 To ml_row_end - ml_row_begin
Cell1.DoGetCellData ll_col, i, lvar_data
lavar_data(i, 0) = lvar_data
lavar_data(i, 1) = i
Next
'以下代码对数组中数据排序(冒泡法）
j = 1
Do While ((j <= ml_row_end - ml_row_begin) And lb_exchange = False)
lb_exchange = True
For i = 0 To ml_row_end - ml_row_begin - j
Select Case mb_sort '升序
Case True
If lavar_data(i, 0) > lavar_data(i + 1, 0) Then
lvar_data1 = lavar_data(i, 0)
ll_data2 = lavar_data(i, 1)
lavar_data(i, 0) = lavar_data(i + 1, 0)
lavar_data(i, 1) = lavar_data(i + 1, 1)
lavar_data(i + 1, 0) = lvar_data1
lavar_data(i + 1, 1) = ll_data2
lb_exchange = False
End If
Case False '降序
If lavar_data(i, 0) < lavar_data(i + 1, 0) Then
lvar_data1 = lavar_data(i, 0)
ll_data2 = lavar_data(i, 1)
lavar_data(i, 0) = lavar_data(i + 1, 0)
lavar_data(i, 1) = lavar_data(i + 1, 1)
lavar_data(i + 1, 0) = lvar_data1
lavar_data(i + 1, 1) = ll_data2
lb_exchange = False
End If
End Select
Next i
Loop
'以下代码根据lvar_data(i,1)所代表的行号对cell1中的单元格进行排序，排序后的值
'先存放在cell2中，排序结束后再用cell2中的值覆盖cell1中的值
For i = 0 To ml_col_end - ml_col_begin
For j = 0 To ml_row_end - ml_row_begin
If Cell1.IsFormulaCell(i, lavar_data(j, 1)) Then
Cell1.DoGetFormula i, lavar_data(j, 1), ls_formula
Cell2.DoSetFormula i, j, ls_formula
Else
Cell1.DoGetCellData i, lavar_data(j, 1), lvar_data
Cell2.DoSetCellData i, j, lvar_data
End If
Next j
Next i
For i = 0 To Cell1.Cols - 1
For j = 0 To Cell1.Rows - 1
If Cell2.IsChartCell(i, j) Then
Cell2.DoGetFormula i, j, ls_formula
Cell1.DoSetFormula i, j, ls_formula
Else
Cell2.DoGetCellData i, j, lvar_data
Cell1.DoSetCellData i, j, lvar_data
End If
Next j
Next i
Cell1.DoRedrawAll
Cell1.DoCalculateAll
Exit Sub
End If
'*************************按行排序*************************************
If ls_type = "row" Then
ReDim lavar_data(ml_col_end - ml_col_begin + 1, 2)
ll_row = Cell1.DoGetCurrentRow
'以下代码把选中的行的数据放入二维数组中
'数组内容：1。 数据，2。数据所在列
For i = 0 To ml_col_end - ml_col_begin
Cell1.DoGetCellData i, ll_row, lvar_data
lavar_data(i, 0) = lvar_data
lavar_data(i, 1) = i
Next
'以下代码对数组中数据排序(冒泡法）
j = 1
Do While ((j <= ml_col_end - ml_col_begin) And lb_exchange = False)
lb_exchange = True
For i = 0 To ml_col_end - ml_col_begin - j
Select Case mb_sort '升序
Case True
If lavar_data(i, 0) > lavar_data(i + 1, 0) Then
lvar_data1 = lavar_data(i, 0)
ll_data2 = lavar_data(i, 1)
lavar_data(i, 0) = lavar_data(i + 1, 0)
lavar_data(i, 1) = lavar_data(i + 1, 1)
lavar_data(i + 1, 0) = lvar_data1
lavar_data(i + 1, 1) = ll_data2
lb_exchange = False
End If
Case False '降序
If lavar_data(i, 0) < lavar_data(i + 1, 0) Then
lvar_data1 = lavar_data(i, 0)
ll_data2 = lavar_data(i, 1)
lavar_data(i, 0) = lavar_data(i + 1, 0)
lavar_data(i, 1) = lavar_data(i + 1, 1)
lavar_data(i + 1, 0) = lvar_data1
lavar_data(i + 1, 1) = ll_data2
lb_exchange = False
End If
End Select
Next i
Loop
'以下代码根据lvar_data(i,1)所代表的列号对cell1中的单元格进行排序，排序后的值
'先存放在cell2中，排序结束后再用cell2中的值覆盖cell1中的值
For i = 0 To ml_row_end - ml_row_begin
For j = 0 To ml_col_end - ml_col_begin
If Cell1.IsFormulaCell(lavar_data(j, 1), i) Then
Cell1.DoGetFormula lavar_data(j, 1), i, ls_formula
Cell2.DoSetFormula j, i, ls_formula
Else
Cell1.DoGetCellData lavar_data(j, 1), i, lvar_data
Cell2.DoSetCellData j, i, lvar_data
End If
Next j
Next i
For i = 0 To Cell1.Cols - 1
For j = 0 To Cell1.Rows - 1
If Cell2.IsChartCell(i, j) Then
Cell2.DoGetFormula i, j, ls_formula
Cell1.DoSetFormula i, j, ls_formula
Else
Cell2.DoGetCellData i, j, lvar_data
Cell1.DoSetCellData i, j, lvar_data
End If
Next j
Next i
Cell1.DoRedrawAll
Cell1.DoCalculateAll
End If
End Sub
Private Sub Cell1_Click()
With Cell1
.DoClearSelection
If Option1.Value = True Then
.DoSelectRange .DoGetCurrentCol, 0, .DoGetCurrentCol, .Rows - 1
Else
.DoSelectRange 0, .DoGetCurrentRow, .Cols - 1, .DoGetCurrentRow
End If
.DoRedrawAll
End With
End Sub
Private Sub Command1_Click()
Dim i As Long, j As Long, ls_formula As String, lvar_data
With MDI_frame.ActiveForm.Cell1
For i = 0 To Cell1.Cols - 1
For j = 0 To Cell1.Rows - 1
If Cell1.IsFormulaCell(i, j) Then
Cell1.DoGetFormula i, j, ls_formula
.DoSetFormula i + ml_col_begin, j + ml_row_begin, ls_formula
Else
Cell1.DoGetCellData i, j, lvar_data
.DoSetCellData i + ml_col_begin, j + ml_row_begin, lvar_data
End If
Next j
Next i
End With
Unload Me
End Sub
Private Sub command2_Click()
Unload Me
End Sub
Private Sub Command3_Click()
If Option1.Value = True Then
mf_sort "col"
Exit Sub
End If
If Option2.Value = True Then
mf_sort "row"
Exit Sub
End If
End Sub
Private Sub Command4_Click()
Dim i As Long, j As Long
Dim ls_formula As String, lvar_data
For i = 0 To Cell1.Cols - 1
For j = 0 To Cell1.Rows - 1
If Cell3.IsFormulaCell(i, j) Then
Cell3.DoGetFormula i, j, ls_formula
Cell1.DoSetFormula i, j, ls_formula
Else
Cell3.DoGetCellData i, j, lvar_data
Cell1.DoSetCellData i, j, lvar_data
End If
Next j
Next i
Cell1.DoRedrawAll
End Sub
Private Sub Form_Load()
Dim i As Long, j As Long, lvar_data, ls_formula As String
If Me.mb_sort = True Then
Me.Caption = "升序排列"
Me.Command3.Caption = "升序排列"
Else
Me.Caption = "降序排列"
Me.Command3.Caption = "降序排列"
End If
With MDI_frame.ActiveForm.Cell1
.DoGetSelectRange ml_col_begin, ml_row_begin, ml_col_end, ml_row_end
Cell1.Cols = ml_col_end - ml_col_begin + 1
Cell1.Rows = ml_row_end - ml_row_begin + 1
Cell2.Cols = ml_col_end - ml_col_begin + 1
Cell2.Rows = ml_row_end - ml_row_begin + 1
Cell3.Cols = ml_col_end - ml_col_begin + 1
Cell3.Rows = ml_row_end - ml_row_begin + 1
'以下代码将需要排序的单元格数据填入cell1,cell3
'cell3用于恢复原样
For i = 0 To ml_col_end - ml_col_begin
For j = 0 To ml_row_end - ml_row_begin
If .IsFormulaCell(i + ml_col_begin, j + ml_row_begin) Then
.DoGetFormula i + ml_col_begin, j + ml_row_begin, ls_formula
Cell1.DoSetFormula i, j, ls_formula
Cell3.DoSetFormula i, j, ls_formula
Else
.DoGetCellData i + ml_col_begin, j + ml_row_begin, lvar_data
Cell1.DoSetCellData i, j, lvar_data
Cell3.DoSetCellData i, j, lvar_data
End If
Next j
Next i
Cell1.DoCalculateAll
Cell1.DoRedrawAll
Cell1.DoSelectRange 0, 0, 0, Cell1.Rows
End With
End Sub
Private Sub Option1_Click()
With Cell1
.DoClearSelection
.DoSelectRange .DoGetCurrentCol, 0, .DoGetCurrentCol, .Rows
.DoRedrawAll
End With
End Sub
Private Sub Option2_Click()
With Cell1
.DoClearSelection
.DoSelectRange 0, .DoGetCurrentRow, .Cols, .DoGetCurrentRow
.DoRedrawAll
End With
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -