(多个工作簿合并成一个工作簿)(怎样把多个工作簿合并成一个工作簿)

实例21-删除工作簿中多个工作表

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