Dim wbname As String
Private Sub CommandButton获取_Click()
'获取工作簿中包含得工作表
With ThisWorkbook.Worksheets("名称列表") '清除原列表数据
.Columns(1).ClearFormats
.Columns(1).ClearContents
.Columns(2).ClearFormats
.Columns(2).ClearContents
End With
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()
Application.Displayalerts = False
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
imax = .Cells(1000000, 1).End(xlUp).Row
For i = 1 To imax
If .Cells(i, 1).Value <> "" And .Cells(i, 2).Value <> "" Then
Workbooks(wbname).Worksheets(CStr(.Cells(i, 1).Value)).Delete
End If
Next i
Workbooks(wbname).Save
MsgBox "处理完成"
End With
Application.Displayalerts = True
End Sub
实例22-提取多个工作表合并为一个工作表Dim wbname As String
Private Sub CommandButton获取_Click()
'获取工作簿中包含得工作表
With ThisWorkbook.Worksheets("名称列表") '清除原列表数据
.Columns(1).ClearFormats
.Columns(1).ClearContents
End With
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()
With ThisWorkbook.Worksheets("提取结果") '清除原列表数据
.UsedRange.ClearFormats
.UsedRange.ClearContents
End With
With ThisWorkbook.Worksheets("操作界面")
If .Cells(2, "C").Value <> "" Then
wbname = .Cells(2, "C").Value
Else
MsgBox "请输入工作簿名称（包含扩展名）"
Exit Sub
End If
Dim extractrange As String
If .Cells(6, "C").Value <> "" Then
extractrange = .Cells(6, "C").Value
Else
MsgBox "请输入提取区域地址"
Exit Sub
End If
End With
Dim addrow As Long
With ThisWorkbook.Worksheets("名称列表")
Dim i As Long
Dim imax As Long
imax = .Cells(1000000, 1).End(xlUp).Row
For i = 1 To imax
If .Cells(i, 1).Value <> "" Then
With ThisWorkbook.Worksheets("提取结果")
addrow = .UsedRange.Cells(.UsedRange.Cells.Count).Row + 2
End With
Workbooks(wbname).Worksheets(CStr(.Cells(i, 1).Value)).Range(extractrange).Copy ThisWorkbook.Worksheets("提取结果").Cells(addrow, 1)
End If
Next i
MsgBox "处理完成"
End With
ThisWorkbook.Worksheets("提取结果").Activate
End Sub
