Петля для вставки изображения в названную названную книгу

Question

Я пытаюсь вставить правильную карту страны JPG в правильную страну XLSX. Под «исправить» Я имею в виду есть одна карта для каждого XLSX - Albania.jpg в Albania.xlxs, Andorra.jpg в Andorra.xlxs и т.д.

Мой макрос сделать следующее:

1. Введите название страны и год в ячейках листа формы пользователя B2 и B3 (отлично работает!).
2. Укажите страны и уровень дохода в странах-участницах таблицы B1 и E1 (работает отлично!).
3. Вставьте карту страны JPG в листе формы пользователя в ячейке A18 (не может получить это в цикл!).
4. Сохраните книгу как CountryName.xlxs (отлично работает!).

Я попытался с помощью Filename = Dir (Path & "* .jpg") и ActiveSheet.Pictures.Insert без успеха. Я думаю, что мне нужно использовать ActiveSheet.Pictures.Insert, потому что ячейки над позицией карты (ячейка A18) будут расширяться, а карта должна двигаться вниз.

Sub SaveCountryYear_XLSX_English_map() 

Dim lRow, x As Integer 
Dim wbName As String 
Dim MapPath As String 'Not used in example below 
Dim MapName As String 'Not used in example below 
Dim index As Integer 

Application.DisplayAlerts = False 
Application.ScreenUpdating = False 

lRow = Range("A" & Rows.Count).End(xlUp).Row 
x = 1 
Do 
x = x + 1 

Worksheets("Countries").Activate 

'1. Enter country name and year in User Form worksheet cells B2 and B3. 

    Range("A" & x).Select 
    Selection.Copy 
    Sheets("User Form").Select 
    Range("B2").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ 
     SkipBlanks:=False, Transpose:=False 
    Sheets("Countries").Select 
    Range("B" & x).Select 
    Selection.Copy 
    Sheets("User Form").Select 
    Range("B3").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ 
     SkipBlanks:=False, Transpose:=False 

'2. Enter country population and income level in Countries worksheet cells B1 and E1. 

    Sheets("Countries").Select 
    Range("C" & x).Select 
    Selection.Copy 
    Sheets("Table").Select 
    Range("B1").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ 
     SkipBlanks:=False, Transpose:=False 
    Sheets("Countries").Select 
    Range("D" & x).Select 
    Selection.Copy 
    Sheets("Table").Select 
    Range("E1").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ 
     SkipBlanks:=False, Transpose:=False 

'3. Insert country map JPG in User Form worksheet at cell A18 
'(cannot get this to loop!). 
'The following is just an example - it works, 
'but without loop of course (inserts the named file correctly). 

    Sheets("User Form").Select 
    Range("A18").Select 
    ActiveSheet.Pictures.Insert(_ 
     "C:\temp\profiles\2017\Maps\EN JPGs\Albania_EN.jpg").Select 

Sheets("Countries").Select 

'4. Save the workbook as CountryName.xlxs. 

    wbName = Range("A" & x).Value & "_" & Range("B" & x).Value & "_EN" 
    ActiveWorkbook.SaveAs Filename:="C:\temp\profiles\2017\Production\Batch_EN_1\" _ 
     & wbName & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 
Loop Until x = lRow 

Application.DisplayAlerts = True 
Application.ScreenUpdating = True 

End Sub 

Answer 1

отредактирован после уточнений OP в

вы можете попробовать этот рефакторинга код:

Option Explicit 

Sub SaveCountryYear_XLSX_English_map() 

    Dim wbName As String 
    Dim MapPath As String 'Not used in example below 
    Dim MapName As String 'Not used in example below 
    Dim index As Integer 'Not used in example below 
    Dim cell As Range 

    Application.DisplayAlerts = False 
    Application.ScreenUpdating = False 


    With Worksheets("Countries") '<--| reference "Countries" worksheet of your currently active workbook 
     For Each cell In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(XlCellType.xlCellTypeConstants, xlTextValues) '<--| loop through referenced worksheet column A cells filled with some text from A2 down to last not empty one 

     '1. Enter country name and year in User Form worksheet cells B2 and B3. 

      Worksheets("User Form").Range("B2").value = cell.value '<--| name is in current cell 
      Worksheets("User Form").Range("B3").value = cell.Offset(, 1).value '<--| date is in adjacent cell 

     '2. Enter country population and income level in Countries worksheet cells B1 and E1. 

      Worksheets("Table").Range("B1").value = cell.Offset(, 2).value '<--| population is in cell two columns right of current one 
      Worksheets("Table").Range("E1").value = cell.Offset(, 3).value '<--| income level is in cell three columns right of current one 


     '3. Insert country map JPG in User Form worksheet at cell A18 
     '(cannot get this to loop!). 
     'The following is just an example - it works, 
     'but without loop of course (inserts the named file correctly). 

      Worksheets("User Form").Activate 
      Range("A18").Select 
      ActiveSheet.Pictures.Insert _ 
       "C:\temp\profiles\2017\Maps\EN JPGs\" _ 
       & cell.value & "_EN.jpg" 


     '4. Save the workbook as CountryName.xlxs. 
      Worksheets.Copy '<--| copy current workbook worksheets to a new workbook 
      ActiveWorkbook.SaveAs Filename:="C:\temp\profiles\2017\Production\Batch_EN_1\" _ 
       & wbName & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 
      ActiveWorkbook.Close 
     Next cell 

    End With 

    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 

End Sub 

где:

• вы должны адаптироваться:

  ActiveSheet.Pictures.Insert _ 
       "C:\temp\profiles\2017\Maps\EN JPGs\" _ 
       & cell.value & "_EN.jpg" 
  

  ваших фактических имен файлов и конвенциям пути источника

• Я изменил раздел 4 (Сохранить книгу как CountryName.xlxs)