实例27-指定区域数字排序，实例28-拆分工作表为工作簿 Excel表格VBA编程实例 代码分享
实例27-指定区域数字排序
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 "对比区域地址不能为空"
Exit Sub
End If
'存储到变量（判断为数字）
Dim cellitem1
Dim data_array() As Double
Dim datacount As Long
For Each cellitem1 In ThisWorkbook.Worksheets("原数据").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 '没有数据
End If
'排序数组
Call sortdata_asc(data_array)
'显示结果
With ThisWorkbook.Worksheets("排序结果")
.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 "对比区域地址不能为空"
Exit Sub
End If
'存储到变量（判断为数字）
Dim cellitem1
Dim data_array() As Double
Dim datacount As Long
For Each cellitem1 In ThisWorkbook.Worksheets("原数据").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 '没有数据
End If
'排序数组
Call sortdata_desc(data_array)
'显示结果
With ThisWorkbook.Worksheets("排序结果")
.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
实例28-拆分工作表为工作簿
Private Sub CommandButton拆分_Click()
'判断工作簿名，文件夹地址不为空
With ThisWorkbook.Worksheets("操作界面")
If Trim(.Cells(2, "C").Value) = "" Or Trim(.Cells(6, "C").Value) = "" Then
MsgBox "参数不能为空"
Exit Sub
End If
'On Error GoTo 处理出错
'定义变量
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)
'循环判断
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
处理出错:
MsgBox Err.Description
End Sub
