|
发表于 2020-11-28 18:04
来自手机
|
显示全部楼层
Sub test()
Application.ScreenUpdating = False '关闭屏幕刷新
Dim shp As shape, sh As Worksheet, i As Integer, j As Integer, rng As Range
On Error Resume Next
For i = 2 To Sheets(1).[a1].End(xlDown).Row
Set rng = Sheets(1).Cells(i, 1) '对应单元格值
Set sh = ThisWorkbook.Sheets("图片" & rng.Value) '对应图片工作表
If sh Is Nothing Then Set sh = Sheets.Add(after:=Sheets(Sheets.Count)): sh.Name = "图片" & rng.Value Else sh.Activate: sh.Shapes.SelectAll: Selection.Delete '检查工作表是否为空,为空则新建工作表,否则激活工作表并删除表内shape对象
sh.[a1] = rng.Value
For j = 2 To 3 '复制图片
Sheets(1).Shapes("图片" & rng.Value & j).Copy
sh.Cells(1, j).Select
sh.Paste
sh.Cells(1, j).RowHeight = Sheets(1).Cells(i, j).RowHeight '单元格高度赋值为原高度
sh.Cells(1, j).ColumnWidth = Sheets(1).Cells(i, j).ColumnWidth '单元格宽度赋值为原宽度
Next
Set sh = Nothing '清空sh引用对象
Next
Sheets(1).Activate '激活工作表1
Application.ScreenUpdating = True '开启屏幕刷新
MsgBox "已完成"
End Sub
|
|