Нужно создать макрос для поиска строки и сопоставить строку с другим открытым листом и вставить соответствующее изображение.

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