實(shí)例31-多個工作表插入圖片，實(shí)例32-多個工作表排序 Excel表格VBA編程實(shí)例 代碼分享
實(shí)例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 "請輸入工作簿名稱（包含擴(kuò)展名）"
Exit Sub
End If
End With
Dim imax As Long
imax = ThisWorkbook.Worksheets("參數(shù)列表").Cells(1000000, 1).End(xlUp).Row
'循環(huán)
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("參數(shù)列表").Cells(i, 1)
With Workbooks(wbname).Worksheets(shname)
picposition = ThisWorkbook.Worksheets("參數(shù)列表").Cells(i, 2)
picpath = ThisWorkbook.Worksheets("參數(shù)列表").Cells(i, 3)
picheight = ThisWorkbook.Worksheets("參數(shù)列表").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("參數(shù)列表") '清除原列表數(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 "請輸入工作簿名稱（包含擴(kuò)展名）"
Exit Sub
End If
End With
Dim i As Integer
For i = 1 To Workbooks(wbname).Worksheets.Count
ThisWorkbook.Worksheets("參數(shù)列表").Cells(i, 1).Value = Workbooks(wbname).Worksheets(i).Name
Next i
ThisWorkbook.Worksheets("參數(shù)列表").Activate
End Sub
實(shí)例32-多個工作表排序
Private Sub CommandButton獲取_Click()
'獲取工作簿中包含的工作表
With ThisWorkbook.Worksheets("名稱列表") '清除原列表數(shù)據(jù)
.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 "請輸入工作簿名稱（包含擴(kuò)展名）"
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 "請輸入工作簿名稱（包含擴(kuò)展名），排序區(qū)域單元格，排序字段單元格"
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 '排序循環(huán)1：升序 2：降序
End With
End If
Next i
End With
Workbooks(wbname).Save
MsgBox "處理完成"
End Sub
