Need a macro to search for a string and match the string from another open worksheet and paste the correspond picture

Question

I am searching for a macro to search a string from worksheet as per given criteria. And it matches the string from another worksheet and paste the picture corresponds to that text. if the string is not found then it should leave that search and search next one. like that i need to do the search string and convert it into pdf file.

here is the sample code

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

In the above example ABC is not found then move the search to next string XYZ. image_s is the worksheet that contains list of pictures related to that name. kindly do the needful

Answer 1

Compiled but not tested:

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