Question

我正在搜索一个宏来根据给定的条件从工作表中搜索字符串。它匹配来自另一个工作表的字符串并粘贴图片对应于该文本。如果找不到该字符串，那么它应该离开该搜索并搜索下一个。就像我需要做搜索字符串并将其转换为pdf文件。

这是示例代码

Sub EXCELTOPDF()

    Dim strPath As String
    Dim strFile, A As String
    Dim NextRow As Long

    strPath = "C:\Users\919944\desktop\xyz"
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    strFile = Dir(strPath & "*.xls", vbNormal)
Do While strFile <> ""

Workbooks.Open strPath & strFile




  On Error Resume Next

If (Cells.Find(What:="ABC", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate) Then
    ActiveCell.Value = ActiveCell.Value()
    ActiveCell.Select
    Windows("Image_S.xlsx").Activate
   Cells.Find(What:="ABC", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    ActiveSheet.Shapes.Range(Array("Picture 123")).Select
    Selection.Copy
    Windows(strFile).Activate
    ActiveCell.Offset(0, 1).Select
    ActiveSheet.Paste
End If



  If (Cells.Find(What:="XYZ", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate) Then

    ActiveCell.Value = ActiveCell.Value()
    ActiveCell.Select
    Windows("Image_S.xlsx").Activate
    Cells.Find(What:="XYZ", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    ActiveSheet.Shapes.Range(Array("Picture 638")).Select
    Selection.Copy
    Windows(strFile).Activate
    ActiveCell.Offset(0, 1).Select
    ActiveSheet.Paste
End if




If (Cells.Find(What:="EFGH", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate) Then
        On Error Resume Next
    ActiveCell.Value = ActiveCell.Value()
    ActiveCell.Select
    Windows("Image_S.xlsx").Activate
    Cells.Find(What:="EFGH", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    ActiveSheet.Shapes.Range(Array("Picture 24")).Select
    Selection.Copy
    Windows(strFile).Activate
    ActiveCell.Offset(0, 1).Select
    ActiveSheet.Paste
End If



If (Cells.Find(What:="PQRS", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate) Then
    ActiveCell.Value = ActiveCell.Value()
    ActiveCell.Select
    Windows("Image_S.xlsx").Activate
    Cells.Find(What:="PQRS", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    ActiveSheet.Shapes.Range(Array("Picture 23")).Select
    Selection.Copy
    Windows(strFile).Activate
    ActiveCell.Offset(0, 1).Select
    ActiveSheet.Paste
End If

 iPtr = InStrRev(ActiveWorkbook.FullName, ".")
If iPtr = 0 Then
    sFileName = ActiveWorkbook.FullName & ".pdf"
  Else
    sFileName = Left(ActiveWorkbook.FullName, iPtr - 1) & ".pdf"
End If

  sFileName = Application.GetSaveAsFilename(InitialFileName:=sFileName, fileFilter:="PDF Files (*.pdf), *.pdf")

If sFileName = "False" Then Exit Sub

  ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, filename:=sFileName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
   strFile = Dir
Loop
 End Sub

在上面的示例中未找到ABC，然后将搜索移动到下一个字符串XYZ。 image_s是包含与该名称相关的图片列表的工作表。请做必要的

Answer 1

已编译但未经过测试：

Sub EXCELTOPDF()

    Dim strPath As String
    Dim strFile, A As String
    Dim NextRow As Long
    Dim wb As Workbook, shtImg As Workbook
    Dim f As Range
    Dim arrFind, arrPic, i

    'array of values to search for
    arrFind = Array("ABC", "DEF", "GHI")
    'array of corresponding shape names
    arrPic = Array("Picture1", "Picture2", "Picture3")

    'get a reference tothe sheet with the images
    Set shtImg = Workbooks("Image_S.xlsx").Sheets("Images")

    strPath = "C:\Users\919944\desktop\xyz"
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

    strFile = Dir(strPath & "*.xls", vbNormal)

    Do While strFile <> ""

        'open the workbook and get a reference to it
        Set wb = Workbooks.Open(strPath & strFile)

        'loop over the array of values to search for
        For i = LBound(arrFind) To UBound(arrFind)

            Set f = wb.Sheets(1).Find(What:=arrFind(i), After:=ActiveCell, _
                                      LookIn:=xlFormulas, LookAt:=xlPart)

            'test to see if value was found (f will not be Nothing)
            If Not f Is Nothing Then
                f.Value = f.Value
                'copy required image...
                shtImg.Shapes(arrPic(i)).Copy
                f.Offset(0, 1).PasteSpecial
            End If

        Next i

        'your export code here....

        strFile = Dir()
    Loop

 End Sub

需要一个宏来搜索字符串并匹配另一个打开的工作表中的字符串并粘贴相应的图片

1 个答案: