实例37-多个工作表指定区域最大最小值
Private Sub CommandButton处理_Click()
(相关资料图)
Dim wbname As String
With ThisWorkbook.Worksheets("操作界面")
If .Cells(2, "C").Value <> "" Then
wbname = .Cells(2, "C").Value
Else
MsgBox "请输入工作簿名称（包含扩展名），查找区域，查找值，替换值"
Exit Sub
End If
End With
With ThisWorkbook.Worksheets("名称列表")
Dim i As Long
Dim imax As Long
Dim shtname As String
Dim findrange As String
Dim maxdata As Double
Dim mindata As Double
imax = .Cells(1000000, 1).End(xlUp).Row
For i = 1 To imax
If .Cells(i, 1).Value <> "" And .Cells(i, 2).Value <> "" Then
shtname = .Cells(i, 1).Value
findrange = .Cells(i, 2).Value
With Workbooks(wbname).Worksheets(shtname)
Dim cellitem
Dim a1 As Integer
a1 = 0
For Each cellitem In .Range(findrange)
If cellitem.Value <> "" And IsNumeric(cellitem.Value) = True Then
If a1 = 0 Then
maxdata = cellitem.Value
mindata = cellitem.Value
a1 = 1
Else
If cellitem.Value > maxdata Then
maxdata = cellitem.Value
End If
If cellitem.Value < mindata Then
mindata = cellitem.Value
End If
End If
End If
Next
End With
End If
.Cells(i, 3).Value = maxdata
.Cells(i, 4).Value = mindata
Next i
.Activate
End With
MsgBox "处理完成"
End Sub
Private Sub CommandButton获取_Click()
'获取工作簿中包含的工作表
With ThisWorkbook.Worksheets("名称列表") '清除原列表数据
.Columns(1).ClearFormats
.Columns(1).ClearContents
End With
Dim wbname As String
With ThisWorkbook.Worksheets("操作界面")
If .Cells(2, "C").Value <> "" Then
wbname = .Cells(2, "C").Value
Else
MsgBox "请输入工作簿名称（包含扩展名）"
Exit Sub
End If
End With
Dim i As Integer
For i = 1 To Workbooks(wbname).Worksheets.Count
ThisWorkbook.Worksheets("名称列表").Cells(i, 1).Value = Workbooks(wbname).Worksheets(i).Name
Next i
ThisWorkbook.Worksheets("名称列表").Activate
End Sub
Private Sub CommandButton处理_Click()
Dim wbname As String
With ThisWorkbook.Worksheets("操作界面")
If .Cells(2, "C").Value <> "" Then
wbname = .Cells(2, "C").Value
Else
MsgBox "请输入工作簿名称（包含扩展名），查找区域，查找值，替换值"
Exit Sub
End If
End With
With ThisWorkbook.Worksheets("名称列表")
Dim i As Long
Dim imax As Long
Dim shtname As String
Dim findrange As String
Dim sumdata As Double
Dim countdata As Double
imax = .Cells(1000000, 1).End(xlUp).Row
For i = 1 To imax
If .Cells(i, 1).Value <> "" And .Cells(i, 2).Value <> "" Then
shtname = .Cells(i, 1).Value
findrange = .Cells(i, 2).Value
With Workbooks(wbname).Worksheets(shtname)
sumdata = 0
countdata = 0
Dim cellitem
For Each cellitem In .Range(findrange)
If cellitem.Value <> "" And IsNumeric(cellitem.Value) = True Then
sumdata = sumdata + cellitem.Value
countdata = countdata + 1
End If
Next
End With
End If
If sumdata = 0 And countdata = 0 Then
.Cells(i, 3).Value = ""
.Cells(i, 4).Value = ""
.Cells(i, 5).Value = ""
Else
.Cells(i, 3).Value = sumdata
.Cells(i, 4).Value = countdata
.Cells(i, 5).Value = sumdata / countdata
End If
Next i
.Activate
End With
MsgBox "处理完成"
End Sub
Private Sub CommandButton获取_Click()
'获取工作簿中包含的工作表
With ThisWorkbook.Worksheets("名称列表") '清除原列表数据
.Columns(1).ClearFormats
.Columns(1).ClearContents
End With
Dim wbname As String
With ThisWorkbook.Worksheets("操作界面")
If .Cells(2, "C").Value <> "" Then
wbname = .Cells(2, "C").Value
Else
MsgBox "请输入工作簿名称（包含扩展名）"
Exit Sub
End If
End With
Dim i As Integer
For i = 1 To Workbooks(wbname).Worksheets.Count
ThisWorkbook.Worksheets("名称列表").Cells(i, 1).Value = Workbooks(wbname).Worksheets(i).Name
Next i
ThisWorkbook.Worksheets("名称列表").Activate
End Sub