在Excel中使用VBA的新手，但是获得了以下宏以成功复制图像（位于单元格T4中并包含在其中）并将其复制到一系列单元格中，这些单元格的尺寸由单元格K15和K17的值指定。因此，如果K15包含6，而K17包含4，则将图像的副本粘贴到T6：Y10范围内的24个单元格中。
Private Sub CommandButton1_Click()
Dim length_count As Integer
Dim width_count As Integer
'Get Length and Width sizes
length_count = Range("K15").Value
width_count = Range("K17").Value
MsgBox "Length is " & length_count & ", Width is " & width_count
'Copy the image located at cell T4
Worksheets("Drawing").Range("T4").Copy
'Select cell range (starting at T6) as defined length and width values
Worksheets("Drawing").Range(Cells(6, 20), Cells(6 + width_count - 1, 20 +
length_count - 1)).Select
'Paste image into each cell in defined range
Worksheets("Drawing").Paste
MsgBox "Drawing complete"
End Sub
我正在努力的是如何选择和删除这些图像，以便在再次执行宏之前“重置”工作表。
任何帮助将不胜感激。
答案 0 :(得分：0)
删除这些图片的代码：
Private Sub CommandButton1_Click()
Dim length_count As Integer
Dim width_count As Integer
Dim pic As Variant
'Get Length and Width sizes
length_count = Range("K15").Value
width_count = Range("K17").Value
MsgBox "Length is " & length_count & ", Width is " & width_count
For Each pic In Worksheets("Drawing").Shapes
If Not Intersect(Range(pic.TopLeftCell, pic.BottomRightCell), Worksheets("Drawing").Range(Cells(6, 20), Cells(6 + width_count - 1, 20 + length_count - 1))) Is Nothing Then
pic.Delete
End If
Next pic
End Sub
通过这种方式，您可以将复制图片的代码简化为：
Private Sub CommandButton1_Click()
Dim length_count As Integer
Dim width_count As Integer
'Get Length and Width sizes
length_count = Range("K15").Value
width_count = Range("K17").Value
MsgBox "Length is " & length_count & ", Width is " & width_count
'Copy the image located at cell T4 and paste it into each cell in defined range
Worksheets("Drawing").Range("T4").Copy Worksheets("Drawing").Range(Cells(6, 20), Cells(6 + width_count - 1, 20 + length_count - 1))
MsgBox "Drawing complete"
End Sub
编辑：评论的答案
Sub AddPics()
Dim ws As Worksheet
Dim length_count As Integer
Dim width_count As Integer
Dim pic() As Variant
Dim picName As String
Dim index As Long
Dim xFilename As String
Dim i As Long
Set ws = Worksheets("Drawing")
picName = "InsertedImage"
'xFilename = "your pics name" 'By default I made it to open the explorer window to choose the picture
'If you want to made it a permanent choice write there its name without extension
'With this code it's going to choose the file with that name in the same folder
'as is the workbook
'The extension is jpg
'If you have a different, modify the code or change so that you write the name with the extensinon
'It is not a problem if explorer windows is used
With ws
'Get Length and Width sizes
'length_count = .Range("K15").Value
length_count = Application.InputBox("Choose the lenght number:", "lenght number", Range("K15").Value, , , , , 1)
'width_count = .Range("K17").Value
width_count = Application.InputBox("Choose the width number:", "width number", Range("K17").Value, , , , , 1)
MsgBox "Length is " & length_count & ", Width is " & width_count
ReDim pic(1 To length_count * width_count)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Copy the image located at cell T4 and paste it into each cell in defined range
.Pictures.Insert(openDialog(Application.ThisWorkbook.Path)).Select 'Open the dialog window
'.Pictures.Insert(Application.ThisWorkbook.Path & "\" & xFilename & ".jpg").Select
Selection.Name = picName & 1
Set pic(1) = .Shapes(picName & 1)
' It resizes the pictures to fit the cells, you may remove this part or modify it
If .Range(.Cells(6, 20), .Cells(6 + width_count - 1, 20 + length_count - 1)).Cells(1).Height > .Range(.Cells(6, 20), .Cells(6 + width_count - 1, 20 + length_count - 1)).Cells(1).Width Then
pic(1).Width = .Range(.Cells(6, 20), .Cells(6 + width_count - 1, 20 + length_count - 1)).Cells(1).Width
Else
pic(1).Height = .Range(.Cells(6, 20), .Cells(6 + width_count - 1, 20 + length_count - 1)).Cells(1).Height
End If
''''''
pic(1).Top = .Range(.Cells(6, 20), .Cells(6 + width_count - 1, 20 + length_count - 1)).Cells(1).Top
pic(1).Left = .Range(.Cells(6, 20), .Cells(6 + width_count - 1, 20 + length_count - 1)).Cells(1).Left
For i = 2 To length_count * width_count
Set pic(i) = pic(1).Duplicate
pic(i).Name = picName & i
pic(i).Top = .Range(.Cells(6, 20), .Cells(6 + width_count - 1, 20 + length_count - 1)).Cells(i).Top
pic(i).Left = .Range(.Cells(6, 20), .Cells(6 + width_count - 1, 20 + length_count - 1)).Cells(i).Left
Next i
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End With
MsgBox "Drawing complete"
End Sub
Sub DeletePics()
Dim ws As Worksheet
Dim length_count As Integer
Dim width_count As Integer
Dim picNumber As Long
Dim picName As String
Dim i As Long
Set ws = Worksheets("Drawing")
picName = "InsertedImage"
With ws
'Get Length and Width sizes
'length_count = .Range("K15").Value
length_count = Application.InputBox("Choose the lenght number:", "lenght number", Range("K15").Value, , , , , 1)
'width_count = .Range("K17").Value
width_count = Application.InputBox("Choose the width number:", "width number", Range("K17").Value, , , , , 1)
MsgBox "Length is " & length_count & ", Width is " & width_count
For i = 1 To length_count * width_count
.Shapes(picName & i).Delete
Next i
End With
End Sub
Sub DeleteAllInsertedPics()
Dim ws As Worksheet
Dim length_count As Integer
Dim width_count As Integer
Dim picNumber As Long
Dim pic As Variant
Set ws = Worksheets("Drawing")
picName = "InsertedImage"
With ws
For Each pic In .Shapes
If Left(pic.Name, Len(picName)) = picName Then
pic.Delete
End If
Next pic
End With
End Sub
Private Function openDialog(defaultPath As String)
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
' Set the title of the dialog box.
.Title = "Please select the file."
' Default path
.InitialFileName = defaultPath
' Clear out the current filters, and add our own.
.Filters.Clear
.Filters.Add "pictures", "*.jpg; *.jpeg; *.png"
.Filters.Add "All Files", "*.*"
' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show = True Then
openDialog = .SelectedItems(1) 'replace txtFileName with your textbox
End If
End With
End Function
我从那里使用并修改了代码：
Open Windows Explorer and select a file
新编辑
Sub AddPics()
Dim ws As Worksheet
Dim length_count As Integer
Dim width_count As Integer
Dim pic() As Variant
Dim picName As String
Dim index As Long
Dim xFilename As String
Dim xRng
Dim i As Long
Set ws = Worksheets("Drawing")
picName = "InsertedImage"
'xFilename = "your pics name" 'By default I made it to open the explorer window to choose the picture
'If you want to make it a permanent choice write there its name without extension
'With this code it's going to choose the file with that name in the same folder
'as is the workbook
'The extension is jpg
'If you have a different extension, modify the code or change it so that you write the name with the extensinon
'It is not a problem if explorer windows is used
With ws
''''''''''''''''''''''''''''''
'Get Length and Width sizes
''''''''''''''''''''''''''''''
'length_count = .Range("K15").Value
'length_count = Application.InputBox("Choose the lenght number:", "lenght number", Range("K15").Value, , , , , 1)
'width_count = .Range("K17").Value
'width_count = Application.InputBox("Choose the width number:", "width number", Range("K17").Value , , , , ,1)
'MsgBox "Length is " & length_count & ", Width is " & width_count
'Set xRng = .Range(.Cells(6, 20), .Cells(6 + width_count - 1, 20 + length_count - 1)) 'Choose the range po pictures
'ReDim pic(1 To length_count * width_count) 'Resizes the size of array of pictures to store them all
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Get Length and Width sizes (optional instead of the previous)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set xRng = Application.InputBox("Select range", "Get Range", , , , , , 8) 'Open Input box for choosing the range
If xRng Is Nothing Then ' That if-statement is added in advance for "On Error Resume Next" which can be used
MsgBox "Empty range was chosen" ' Now empty range terminates the procedure anyway
Exit Sub
End If
length_count = xRng.Columns.Count
width_count = xRng.Rows.Count
MsgBox "Length is " & length_count & ", Width is " & width_count
ReDim pic(1 To length_count * width_count) 'Resizes the size of array of pictures to store them all
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Insert an image
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set pic(1) = .Pictures.Insert(openDialog(Application.ThisWorkbook.Path)) 'It opens the dialog window
'In openDialog() pass the defaulty path
'In my case it is 'Application.ThisWorkbook.Path'
'Set pic(1) = .Pictures.Insert(Application.ThisWorkbook.Path & "\" & xFilename & ".jpg")
pic(1).Name = picName & 1
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' It resizes the pictures to fit the cells, you may remove this part or modify it
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If xRng.Cells(1).Height > xRng.Cells(1).Width Then
pic(1).Width = xRng.Cells(1).Width
If pic(1).Height > xRng.Cells(1).Height Then
pic(1).Height = xRng.Cells(1).Height
End If
Else
pic(1).Height = xRng.Cells(1).Height
If pic(1).Width > xRng.Cells(1).Width Then
pic(1).Width = xRng.Cells(1).Width
End If
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Position the picture in the first cell (the part after plus sign is to center the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
pic(1).Top = xRng.Cells(1).Top + 0.5 * (xRng.Cells(1).Height - pic(1).Height)
pic(1).Left = xRng.Cells(1).Left + 0.5 * (xRng.Cells(1).Width - pic(1).Width)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Duplicate and position the rest of the pictures in the xRng (the selected range) (the part after plus sign is to center the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For i = 2 To length_count * width_count
Set pic(i) = pic(1).Duplicate
pic(i).Name = picName & i
pic(i).Top = xRng.Cells(i).Top + 0.5 * (xRng.Cells(i).Height - pic(i).Height)
pic(i).Left = xRng.Cells(i).Left + 0.5 * (xRng.Cells(i).Width - pic(i).Width)
Next i
End With
MsgBox "Drawing complete"
End Sub
Sub DeletePics()
Dim ws As Worksheet
Dim length_count As Integer
Dim width_count As Integer
Dim picNumber As Long
Dim picName As String
Dim i As Long
Set ws = Worksheets("Drawing")
picName = "InsertedImage"
With ws
''''''''''''''''''''''''''''''
'Get Length and Width sizes
''''''''''''''''''''''''''''''
'length_count = .Range("K15").Value
'length_count = Application.InputBox("Choose the lenght number:", "lenght number", Range("K15").Value, , , , , 1)
'width_count = .Range("K17").Value
'width_count = Application.InputBox("Choose the width number:", "width number", Range("K17").Value , , , , ,1)
'MsgBox "Length is " & length_count & ", Width is " & width_count
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Get Length and Width sizes (optional instead of the previous)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set xRng = Application.InputBox("Select range", "Get Range", , , , , , 8) 'Open Input box for choosing the range
If xRng Is Nothing Then ' That if-statement is added in advance for "On Error Resume Next" which can be used
MsgBox "Empty range was chosen" ' Now empty range terminates the procedure anyway
Exit Sub ' Unfortunately if the pictures fill the cells almost completely
End If ' One cannot select the range and has to write it manually in the InputBox
length_count = xRng.Columns.Count
width_count = xRng.Rows.Count
MsgBox "Length is " & length_count & ", Width is " & width_count
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Delete pictures in selected cells
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For i = 1 To length_count * width_count
.Shapes(picName & i).Delete
Next i
End With
End Sub
Sub DeleteAllInsertedPics()
Dim ws As Worksheet
Dim length_count As Integer
Dim width_count As Integer
Dim picNumber As Long
Dim pic As Variant
Set ws = Worksheets("Drawing")
picName = "InsertedImage"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Delete all the pictures that start with picName (the best option to delete I guess)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With ws
For Each pic In .Shapes
If Left(pic.Name, Len(picName)) = picName Then
pic.Delete
End If
Next pic
End With
End Sub
Private Function openDialog(defaultPath As String)
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
' Set the title of the dialog box.
.Title = "Please select the file."
' Default path
.InitialFileName = defaultPath
' Clear out the current filters, and add our own.
.Filters.Clear
.Filters.Add "pictures", "*.jpg; *.jpeg; *.png"
.Filters.Add "All Files", "*.*"
' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show = True Then
openDialog = .SelectedItems(1) 'replace txtFileName with your textbox
End If
End With
End Function
为解决excel 2007错误而进行的修改（在注释中查找）。
说实话，我真的不知道为什么会发生该错误。 我现在将pic（）数组声明为Shape而不是Variant。它不会产生问题，但是我无法插入图片并将其分配给Shape对象，因此我创建了一个新的Picture对象（pic_one），然后将其分配给Shape对象（pic（1））
Sub AddPics()
Dim ws As Worksheet
Dim length_count As Integer
Dim width_count As Integer
Dim pic_one As Picture
Dim pic() As Shape
Dim picName As String
Dim index As Long
Dim xFilename As String
Dim xRng
Dim i As Long
Set ws = Worksheets("Drawing")
picName = "InsertedImage"
'xFilename = "your pics name" 'By default I made it to open the explorer window to choose the picture
'If you want to make it a permanent choice write there its name without extension
'With this code it's going to choose the file with that name in the same folder
'as is the workbook
'The extension is jpg
'If you have a different extension, modify the code or change it so that you write the name with the extensinon
'It is not a problem if explorer windows is used
With ws
''''''''''''''''''''''''''''''
'Get Length and Width sizes
''''''''''''''''''''''''''''''
'length_count = .Range("K15").Value
'length_count = Application.InputBox("Choose the lenght number:", "lenght number", Range("K15").Value, , , , , 1)
'width_count = .Range("K17").Value
'width_count = Application.InputBox("Choose the width number:", "width number", Range("K17").Value , , , , ,1)
'MsgBox "Length is " & length_count & ", Width is " & width_count
'Set xRng = .Range(.Cells(6, 20), .Cells(6 + width_count - 1, 20 + length_count - 1)) 'Choose the range po pictures
'ReDim pic(1 To length_count * width_count) 'Resizes the size of array of pictures to store them all
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Get Length and Width sizes (optional instead of the previous)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set xRng = Application.InputBox("Select range", "Get Range", , , , , , 8) 'Open Input box for choosing the range
If xRng Is Nothing Then ' That if-statement is added in advance for "On Error Resume Next" which can be used
MsgBox "Empty range was chosen" ' Now empty range terminates the procedure anyway
Exit Sub
End If
length_count = xRng.Columns.Count
width_count = xRng.Rows.Count
MsgBox "Length is " & length_count & ", Width is " & width_count
ReDim pic(1 To length_count * width_count) 'Resizes the size of array of pictures to store them all
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Insert an image
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set pic_one = .Pictures.Insert(openDialog(Application.ThisWorkbook.Path)) 'It opens the dialog window
'In openDialog() pass the defaulty path
'In my case it is 'Application.ThisWorkbook.Path'
'Set pic_one = .Pictures.Insert(Application.ThisWorkbook.Path & "\" & xFilename & ".jpg")
pic_one.Name = picName & 1
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' It resizes the pictures to fit the cells, you may remove this part or modify it
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If xRng.Cells(1).Height > xRng.Cells(1).Width Then
pic_one.Width = xRng.Cells(1).Width
If pic_one.Height > xRng.Cells(1).Height Then
pic_one.Height = xRng.Cells(1).Height
End If
Else
pic_one.Height = xRng.Cells(1).Height
If pic_one.Width > xRng.Cells(1).Width Then
pic_one.Width = xRng.Cells(1).Width
End If
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Position the picture in the first cell (the part after plus sign is to center the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
pic_one.Top = xRng.Cells(1).Top + 0.5 * (xRng.Cells(1).Height - pic_one.Height)
pic_one.Left = xRng.Cells(1).Left + 0.5 * (xRng.Cells(1).Width - pic_one.Width)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Duplicate and position the rest of the pictures in the xRng (the selected range) (the part after plus sign is to center the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set pic(1) = .Shapes(picName & 1)
For i = 2 To length_count * width_count
Set pic(i) = pic(1).Duplicate
pic(i).Name = picName & i
pic(i).Top = xRng.Cells(i).Top + 0.5 * (xRng.Cells(i).Height - pic(i).Height)
pic(i).Left = xRng.Cells(i).Left + 0.5 * (xRng.Cells(i).Width - pic(i).Width)
Next i
End With
MsgBox "Drawing complete"
End Sub
Sub DeletePics()
Dim ws As Worksheet
Dim length_count As Integer
Dim width_count As Integer
Dim picNumber As Long
Dim picName As String
Dim i As Long
Set ws = Worksheets("Drawing")
picName = "InsertedImage"
With ws
''''''''''''''''''''''''''''''
'Get Length and Width sizes
''''''''''''''''''''''''''''''
'length_count = .Range("K15").Value
'length_count = Application.InputBox("Choose the lenght number:", "lenght number", Range("K15").Value, , , , , 1)
'width_count = .Range("K17").Value
'width_count = Application.InputBox("Choose the width number:", "width number", Range("K17").Value , , , , ,1)
'MsgBox "Length is " & length_count & ", Width is " & width_count
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Get Length and Width sizes (optional instead of the previous)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set xRng = Application.InputBox("Select range", "Get Range", , , , , , 8) 'Open Input box for choosing the range
If xRng Is Nothing Then ' That if-statement is added in advance for "On Error Resume Next" which can be used
MsgBox "Empty range was chosen" ' Now empty range terminates the procedure anyway
Exit Sub ' Unfortunately if the pictures fill the cells almost completely
End If ' One cannot select the range and has to write it manually in the InputBox
length_count = xRng.Columns.Count
width_count = xRng.Rows.Count
MsgBox "Length is " & length_count & ", Width is " & width_count
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Delete pictures in selected cells
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For i = 1 To length_count * width_count
.Shapes(picName & i).Delete
Next i
End With
End Sub
Sub DeleteAllInsertedPics()
Dim ws As Worksheet
Dim length_count As Integer
Dim width_count As Integer
Dim picNumber As Long
Dim pic As Variant
Set ws = Worksheets("Drawing")
picName = "InsertedImage"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Delete all the pictures that start with picName (the best option to delete I guess)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With ws
For Each pic In .Shapes
If Left(pic.Name, Len(picName)) = picName Then
pic.Delete
End If
Next pic
End With
End Sub
Private Function openDialog(defaultPath As String)
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
' Set the title of the dialog box.
.Title = "Please select the file."
' Default path
.InitialFileName = defaultPath
' Clear out the current filters, and add our own.
.Filters.Clear
.Filters.Add "pictures", "*.jpg; *.jpeg; *.png"
.Filters.Add "All Files", "*.*"
' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show = True Then
openDialog = .SelectedItems(1) 'replace txtFileName with your textbox
End If
End With
End Function