實(shí)例27-指定區(qū)域數(shù)字排序，實(shí)例28-拆分工作表為工作簿 Excel表格VBA編程實(shí)例 代碼分享
實(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
