實(shí)例27-指定區(qū)域數(shù)字排序

Private Sub CommandButton排序_Click()

Dim sortrange As String

If ThisWorkbook.Worksheets("操作界面").Cells(2, "C").Value <> "" Then

sortrange = ThisWorkbook.Worksheets("操作界面").Cells(2, "C").Value

Else

MsgBox "對(duì)比區(qū)域地址不能為空"

Exit Sub

End If

'存儲(chǔ)到變量（判斷為數(shù)字）

Dim cellitem1

Dim data_array() As Double

Dim datacount As Long

For Each cellitem1 In ThisWorkbook.Worksheets("原數(shù)據(jù)").Range(sortrange)

If cellitem1.Value <> "" And IsNumeric(cellitem1.Value) = True Then

ReDim Preserve data_array(datacount)

data_array(datacount) = cellitem1.Value

datacount = datacount + 1

End If

Next cellitem1

If datacount <= 1 Then

Exit Sub '沒有數(shù)據(jù)

End If

'排序數(shù)組

Call sortdata_asc(data_array)

'顯示結(jié)果

With ThisWorkbook.Worksheets("排序結(jié)果")

.Columns(1).ClearFormats

.Columns(1).ClearContents

Dim i

For i = 0 To UBound(data_array)

.Cells(i + 1, 1).Value = data_array(i)

Next i

.Activate

End With

End Sub

Public Sub sortdata_asc(ByRef dataarray) '升序

Dim data1 As Double

Dim data2 As Double

Dim i, j

For i = 0 To UBound(dataarray) - 1

For j = i To UBound(dataarray)

If dataarray(i) > dataarray(j) Then

data1 = dataarray(i)

data2 = dataarray(j)

dataarray(i) = data2

dataarray(j) = data1

End If

Next j

Next i

End Sub

Public Sub sortdata_desc(ByRef dataarray) '降序

Dim data1 As Double

Dim data2 As Double

Dim i, j

For i = 0 To UBound(dataarray) - 1

For j = i To UBound(dataarray)

If dataarray(i) < dataarray(j) Then

data1 = dataarray(i)

data2 = dataarray(j)

dataarray(i) = data2

dataarray(j) = data1

End If

Next j

Next i

End Sub

Private Sub CommandButton排序2_Click()

Dim sortrange As String

If ThisWorkbook.Worksheets("操作界面").Cells(2, "C").Value <> "" Then

sortrange = ThisWorkbook.Worksheets("操作界面").Cells(2, "C").Value

Else

MsgBox "對(duì)比區(qū)域地址不能為空"

Exit Sub

End If

'存儲(chǔ)到變量（判斷為數(shù)字）

Dim cellitem1

Dim data_array() As Double

Dim datacount As Long

For Each cellitem1 In ThisWorkbook.Worksheets("原數(shù)據(jù)").Range(sortrange)

If cellitem1.Value <> "" And IsNumeric(cellitem1.Value) = True Then

ReDim Preserve data_array(datacount)

data_array(datacount) = cellitem1.Value

datacount = datacount + 1

End If

Next cellitem1

If datacount <= 1 Then

Exit Sub '沒有數(shù)據(jù)

End If

'排序數(shù)組

Call sortdata_desc(data_array)

'顯示結(jié)果

With ThisWorkbook.Worksheets("排序結(jié)果")

.Columns(1).ClearFormats

.Columns(1).ClearContents

Dim i

For i = 0 To UBound(data_array)

.Cells(i + 1, 1).Value = data_array(i)

Next i

.Activate

End With

End Sub

實(shí)例28-拆分工作表為工作簿

Private Sub CommandButton拆分_Click()

'判斷工作簿名，文件夾地址不為空

With ThisWorkbook.Worksheets("操作界面")

If Trim(.Cells(2, "C").Value) = "" Or Trim(.Cells(6, "C").Value) = "" Then

MsgBox "參數(shù)不能為空"

Exit Sub

End If

'On Error GoTo 處理出錯(cuò)

'定義變量

Dim wbname As String

wbname = Trim(.Cells(2, "C").Value)

Dim savefolder As String

savefolder = Trim(.Cells(6, "C").Value)

End With

'處理表格

With Workbooks(wbname)

'循環(huán)判斷

Dim i

For i = 1 To .Worksheets.Count

.Worksheets(i).Copy

ActiveWorkbook.SaveAs Filename:=savefolder & "\" & .Worksheets(i).Name & ".xlsx"

ActiveWorkbook.Worksheets(1).Name = .Worksheets(i).Name

ActiveWorkbook.Close savechanges:=True

Next i

End With

MsgBox "處理完成"

Exit Sub

處理出錯(cuò):

MsgBox Err.Description

End Sub