實例23-提取多個工作表數(shù)據(jù)，實例24-根據(jù)模板生成多個工作表 Excel表格VBA編程實例 代
實例23-提取多個工作表數(shù)據(jù)
Dim wbname As String
Private Sub CommandButton獲取_Click()
'獲取工作簿中包含的工作表
With ThisWorkbook.Worksheets("名稱列表") '清除原列表數(shù)據(jù)
.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-根據(jù)模板生成多個工作表
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
