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, 1).Value = Workbooks(wbname).Worksheets(i).Name
ThisWorkbook.Worksheets("名称列表").Cells(1, 1).Value = "工作表名称"
Next i
ThisWorkbook.Worksheets("名称列表").Activate
End Sub
Private Sub CommandButton提取_Click()
With ThisWorkbook.Worksheets("操作界面")
If .Cells(2, "C").Value <> "" Then
wbname = .Cells(2, "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
Dim j As Long
Dim jmax As Long
Dim shtname As String
imax = .Cells(1000000, 1).End(xlUp).Row
jmax = ThisWorkbook.Worksheets("提取结果").Cells(1, 10000).End(xlToLeft).Column
For i = 2 To imax
If .Cells(i, 1).Value <> "" Then
shtname = .Cells(i, 1).Value
addrow = i
With ThisWorkbook.Worksheets("提取结果")
.Rows(i).ClearContents
.Rows(i).ClearFormats
For j = 1 To jmax
If .Cells(1, j).Value <> "" Then
.Cells(i, j).Value = Workbooks(wbname).Worksheets(shtname).Range(CStr(.Cells(1, j).Value))
End If
Next j
End With
End If
Next i
MsgBox "处理完成"
End With
ThisWorkbook.Worksheets("提取结果").Activate
End Sub
实例24-根据模板生成多个工作表Private Sub CommandButton生成_Click()
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("操作界面")
Dim wbname As String
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 j As Long
Dim jmax As Long
Dim shtname As String
imax = .Cells(1000000, 1).End(xlUp).Row
jmax = .Cells(1, 10000).End(xlToLeft).Column
For i = 2 To imax
If .Cells(i, 1).Value <> "" Then
shtname = .Cells(i, 1).Value
ThisWorkbook.Worksheets("模板").Copy after:=Workbooks(wbname).Worksheets(Workbooks(wbname).Worksheets.Count)
Workbooks(wbname).Worksheets(Workbooks(wbname).Worksheets.Count).Name = shtname
Workbooks(wbname).Save
For j = 2 To jmax
If .Cells(1, j).Value <> "" Then
Workbooks(wbname).Worksheets(shtname).Range(CStr(.Cells(1, j).Value)) = .Cells(i, j).Value
End If
Next j
End If
Next i
MsgBox "处理完成"
End With
Workbooks(wbname).Save
Application.ScreenUpdating = True
End Sub
