企业管理

开发平台：
Visual Basic

-：源码内容
							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

						