Question

我觉得我接近于设置了我的语法，但是编译会立即突出显示某些红色线条，表明它们不正确，我不知道如何在VBA中选择指定的单元格。我想要做的是打开模板工作簿，复制工作簿的图像表单。然后打开目录中的所有工作簿，从sheet1中删除图像，粘贴复制的图像，从sheet2中删除图像并粘贴复制的图像，保存，关闭，下一个工作簿。

这是我的语法，有人可以帮我解决这个问题吗？

Sub ReplaceImage()

Dim fList() As String, fName As String, fPath As String
Dim intFno As Integer
Dim rngPaste As Range
Dim WB As Workbook, wbOpened As Workbook
Dim strmasterFile As String
Dim shape as Excel.shape

strMasterFile = “C:\Image_Template.xlsx”
Set wbOpened = Workbooks.Open(strmasterFile)
With Sheets(1)
    if shape.name = "Picture 1" Then
        shape.Select
        Selection.Copy
    end if
 End With
Set WB = ActiveWorkbook
fPath = “C:\NewFormat\” & “\”
If MsgBox(“Collect all sample files in the current dir:” & vbCrLf & fPath, vbYesNo) = vbYes Then
intFno = 0
fName = Dir(fPath & “ * .xlsx”)

While fName <> “”
intFno = intFno + 1
ReDim Preserve fList(1 To intFno)
fList(intFno) = fName
fName = Dir()
Wend

  If intFno = 0 Then
    MsgBox “No files found”
  Exit Sub
  End If
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For intFno = 1 To UBound(fList)
  On Error GoTo Skip
  Set wbOpened = Workbooks.Open(fPath & fList(intFno))
  With Sheets(1)
    For Each shape In ActiveSheet.Shapes
    if shape.name = "Picture 19" Then
      shape.Delete
    end if
 next
'Paste Image to Cell A84 and of course it will expand across
End With
With Sheets(2)
  For Each shape In ActiveSheet.Shapes
  if shape.name = "Picture 6" Then
    shape.Delete
  end if
next
'Paste Image to Cell A88 and of course it will expand across
End With
wbOpened.Close False
Skip:
Next
Else: End If

End Sub

编辑 - 这些是立即将字体颜色更改为红色

的罪魁祸首

strMasterFile = “C:\Image_Template.xlsx”

fPath = “C:\NewFormat\” & “\”
If MsgBox(“Collect all sample files in the current dir:” & vbCrLf & fPath, vbYesNo) = vbYes Then

MsgBox “No files found”

删除智能报价摆脱了直接的红线!!!!现在我的最后一块饼。实际上将图像粘贴到每个工作表上的所需单元格？

一步关闭 - 第一次迭代将免费发布，第二次工作簿将抛出错误

工作表类的粘贴方法失败

在这一行

ActiveSheet.Paste

这是我的完整更新代码

Sub ReplaceImage()

Dim fList() As String, fName As String, fPath As String
Dim intFno As Integer
Dim rngPaste As Range
Dim WB As Workbook, wbOpened As Workbook
Dim strmasterFile As String
Dim shape As Excel.shape

strmasterFile = "C:\Image_Template.xlsx"
Set wbOpened = Workbooks.Open(strmasterFile)
With Sheets(1)
  Rows("1:4").Select
  Selection.Copy
End With
Set WB = ActiveWorkbook
fPath = "C:\NewFormat\" & "\"
If MsgBox("Collect all sample files in the current dir:" & vbCrLf & fPath, vbYesNo) = vbYes Then
intFno = 0
fName = Dir(fPath & "*.xlsx")

While fName <> “”
  intFno = intFno + 1
  ReDim Preserve fList(1 To intFno)
  fList(intFno) = fName
  fName = Dir()
Wend

If intFno = 0 Then
  MsgBox "No files found"
  Exit Sub
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For intFno = 1 To UBound(fList)
  On Error GoTo Skip
  Set wbOpened = Workbooks.Open(fPath & fList(intFno))
  With Sheets(1)
    For Each shape In ActiveSheet.Shapes
      If shape.Name = "Picture 19" Then
        shape.Delete
      End If
    Next shape
    Rows("84:84").Select
    ActiveSheet.Paste
  End With
  With Sheets(2)
    For Each shape In ActiveSheet.Shapes
      If shape.Name = "Picture 6" Then
        shape.Delete
      End If
    Next shape
    Rows("88:88").Select
    ActiveSheet.Paste
  End With
  Sheets(1).Select
  wbOpened.Save
wbOpened.Close False
Skip:
  Next
Else: End If

End Sub

Answer 1

也许不是问题，但评论的时间太长了。

您的With块看起来很时髦 - 您错过了将所附子项绑定到With对象的前导句点。

With Sheets(1)
  Rows("1:4").Select  '<< defaults to active sheet
  Selection.Copy
End With

应该是：

With Sheets(1)
  .Rows("1:4").Select  '<< leading period ties this to Sheets(1)
  Selection.Copy
End With

此外：

fPath = “C:\NewFormat\” & “\”

你的意思是用两个反斜杠终止吗？

迭代目录删除然后导入图像

1 个答案: