Range("B1")=...

Sub iPerenos()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim Result As Worksheet
Dim j As Integer
  Set Result = ThisWorkbook.Worksheets("Результат")
   iLastRow = Result.Cells(Result.Rows.Count, "A").End(xlUp).Row + 1
   Result.Range("A2:C" & iLastRow).ClearContents
With Worksheets("Исходные данные")
   iLastRow = Cells(Rows.Count, "D").End(xlUp).Row
  For i = 2 To iLastRow
    Set FoundCell = .Columns(1).Find(Cells(i, "D"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
       Result.Range("A" & Result.Cells(Result.Rows.Count, "A").End(xlUp).Row + 1).Resize(12) = FoundCell
       .Range(.Cells(1, "B"), .Cells(1, "M")).Copy
       Result.Range("B" & Result.Cells(Result.Rows.Count, "B").End(xlUp).Row + 1).PasteSpecial _
               xlPasteValues, , Transpose:=True
       .Range(.Cells(FoundCell.Row, "B"), .Cells(FoundCell.Row, "M")).Copy
       Result.Range("C" & Result.Cells(Result.Rows.Count, "C").End(xlUp).Row + 1).PasteSpecial _
               xlPasteValues, , Transpose:=True
     End If
  Next
End With
End Sub

Sub Выборка()
Dim lLastRow As Long
Dim i&, Inp1 As Range
'подстановка значений в лист "Нужный формат"
  Set Inp1 = Worksheets("Нужный формат").Range("B1")
  lLastRow = Worksheets("Список магазинов").Cells(Rows.Count, 4).End(xlUp).Row
With Sheets("Список магазинов")
  For i = 2 To lLastRow
    Inp1 = .Cells(i, "D")
  'копирование данных на лист "Результат"
Dim YLastRow As Long
    YLastRow = Worksheets("Результат").Cells(Rows.Count, 1).End(xlUp).Row
    Worksheets("Нужный формат").Range("A3:C14").Copy
   With Worksheets("Результат").Cells(YLastRow + 1, 1)
     .PasteSpecial Paste:=xlPasteValues
     .PasteSpecial Paste:=xlPasteFormats
   End With
  Next
End With
End Sub