实例31-多个工作表插入图片，实例32-多个工作表排序 Excel表格VBA编程实例 代码分享
实例31-多个工作表插入图片
Dim wbname As String
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 imax As Long
imax = ThisWorkbook.Worksheets("参数列表").Cells(1000000, 1).End(xlUp).Row
'循环
Dim i
Dim picposition As String
Dim picpath As String
Dim picheight As Long
Dim shname As String
For i = 1 To imax
shname = ThisWorkbook.Worksheets("参数列表").Cells(i, 1)
With Workbooks(wbname).Worksheets(shname)
picposition = ThisWorkbook.Worksheets("参数列表").Cells(i, 2)
picpath = ThisWorkbook.Worksheets("参数列表").Cells(i, 3)
picheight = ThisWorkbook.Worksheets("参数列表").Cells(i, 4)
If picposition <> "" And picpath <> "" And picheight <> 0 Then
.Shapes.AddPicture picpath, 0, True, .Range(picposition).Left, .Range(picposition).Top, -1, -1
.Shapes(.Shapes.Count).LockAspectRatio = msoTrue
.Shapes(.Shapes.Count).Height = picheight
End If
End With
Next i
Workbooks(wbname).Save
MsgBox "处理完成"
End Sub
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
实例32-多个工作表排序
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
Private Sub CommandButton排序_Click()
Dim wbname As String
Dim sortrange As String
Dim sortfiled As String
With ThisWorkbook.Worksheets("操作界面")
If .Cells(2, "C").Value <> "" Or .Cells(6, "C").Value <> "" Or .Cells(10, "C").Value <> "" Then
wbname = .Cells(2, "C").Value
sortrange = .Cells(6, "C").Value
sortfiled = .Cells(10, "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
imax = .Cells(1000000, 1).End(xlUp).Row
For i = 1 To imax
If .Cells(i, 1).Value <> "" Then
shtname = .Cells(i, 1).Value
With Workbooks(wbname).Worksheets(shtname)
.Range(sortrange).CurrentRegion.Sort key1:=.Range(sortfiled), order1:=2, Header:=xlGuess, MatchCase:=False '排序循环1：升序 2：降序
End With
End If
Next i
End With
Workbooks(wbname).Save
MsgBox "处理完成"
End Sub
