实例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

实例38-多个工作表指定区域求和平均计数

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