VBA Loop для заполнения листа

Question

Мне нужно скопировать данные в шаблон, но я не уверен, как создать одну строку, которая включает все диапазоны и ячейки, чтобы сделать мой код меньше.Прямо сейчас я использую 13 строк, чтобы заполнить один из 20 продуктов в шаблоне.Может кто-нибудь помочь с этим?Очень ценится

Dim FileName As String
FileName = ""

With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select File"
    .Filters.Add "Excel File", "*.xls?"
    .AllowMultiSelect = False

    If .Show Then
        FileName = .SelectedItems(1)
    End If
End With
If Len(FileName) < 4 Then Exit Sub 'No file selected

Dim TempWorkbook As Workbook, currentSheet As Worksheet
Set currentSheet = ActiveSheet 'Store the ActiveSheet, it will change
Set TempWorkbook = Workbooks.Open(FileName, ReadOnly:=True)

     For Index = 8 To 11

            currentSheet.Range("T" & Index).FormulaR1C1 = "=" & TempWorkbook.Worksheets("FINAL FORM").Cells((Index + 10), 2).Address(True, True, xlR1C1, True)
            currentSheet.Range("U" & Index).FormulaR1C1 = "=" & TempWorkbook.Worksheets("FINAL FORM").Cells((Index + 10), 4).Address(True, True, xlR1C1, True)
            currentSheet.Range("V" & Index).FormulaR1C1 = "=" & TempWorkbook.Worksheets("FINAL FORM").Cells((Index + 10), 9).Address(True, True, xlR1C1, True)
            currentSheet.Range("W" & Index).FormulaR1C1 = "=" & TempWorkbook.Worksheets("FINAL FORM").Cells((Index + 10), 13).Address(True, True, xlR1C1, True)
            currentSheet.Range("X" & Index).FormulaR1C1 = "=" & TempWorkbook.Worksheets("FINAL FORM").Cells((Index + 10), 17).Address(True, True, xlR1C1, True)
            currentSheet.Range("Y" & Index).FormulaR1C1 = "=" & TempWorkbook.Worksheets("FINAL FORM").Cells((Index + 10), 21).Address(True, True, xlR1C1, True)
            currentSheet.Range("Z" & Index).FormulaR1C1 = "=" & TempWorkbook.Worksheets("FINAL FORM").Cells((Index + 10), 25).Address(True, True, xlR1C1, True)

      Next

НОВОЕ РЕДАКТИРОВАНИЕ:

Dim FileName As String
FileName = ""

With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select File"
    .Filters.Add "Excel File", "*.xls?"
    .AllowMultiSelect = False

    If .Show Then
        FileName = .SelectedItems(1)
    End If
End With
If Len(FileName) < 4 Then Exit Sub 'No file selected

Dim TempWorkbook As Workbook, currentSheet As Worksheet
Set currentSheet = ActiveSheet 'Store the ActiveSheet, it will change
Set TempWorkbook = Workbooks.Open(FileName, ReadOnly:=True)
Dim TempSheet As Worksheet: Set TempSheet = TempWorkbook.Worksheets("FINAL FORM")
Dim i As Double
Dim Index As Double
Dim arrz As Variant
arrz = Array(2, 4, 9, 13, 17, 21, 25, 29, 30, 36, 37, 38, 39)
For Index = 8 To 11
        For i = 20 To 32
                currentSheet.Cells(Index, i).FormulaR1C1 = "=" & TempSheet.Cells((Index + 10), arrz(i - 39)).Address(True, True, xlR1C1, True)
                currentSheet.Cells((Index + 7), i).FormulaR1C1 = "=" & TempSheet.Cells((Index + 21), arrz(i - 39)).Address(True, True, xlR1C1, True)
        Next i
Next Index
End Sub

Answer 1

Это должно работать для того, что вы спрашиваете, выглядит немного чище:

Dim arr() As Variant, arr2() As Variant
arr = Array(2, 4, 9, 13, 17, 21, 25)

For cl = 20 To 26
    For rw = 8 To 11
        currentSheet.Cells(rw, cl).FormulaR1C1 = "=" & TempWorkbook.Worksheets("FINAL FORM").Cells((rw + 10), arr(cl - 20)).Address(True, True, xlR1C1, True)
    Next

    For rw = 15 To 18
        currentSheet.Cells(rw, cl).FormulaR1C1 = "=" & TempWorkbook.Worksheets("FINAL FORM").Cells((rw + 14), arr(cl - 20)).Address(True, True, xlR1C1, True)
    Next
Next

Answer 2

Вместо этого я решил сделать два блока в одном цикле с некоторыми математическими задачами, а также затемнить рабочие листы, чтобы они работали с моим тестом.Очевидно, вы меняете их на нужные вам листы.

Sub Copy()
Dim FileName As String
FileName = ""

With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select File"
    .Filters.Add "Excel File", "*.xls?"
    .AllowMultiSelect = False

    If .Show Then
        FileName = .SelectedItems(1)
    End If
End With
If Len(FileName) < 4 Then Exit Sub 'No file selected

Dim TempWorkbook As Workbook, currentSheet As Worksheet
Set currentSheet = ActiveSheet 'Store the ActiveSheet, it will change
Set TempWorkbook = Workbooks.Open(FileName, ReadOnly:=True)
Dim TempSheet As Worksheet: Set TempSheet = TempWorkbook.Worksheets("FINAL FORM")
Dim i As Double
Dim Index As Double
Dim arrz As Variant
arrz = Array(2, 4, 9, 13, 17, 21, 25, 29, 33, 36, 37, 38, 39)
For Index = 8 To 11
        For i = 20 To 32
        currentSheet.Cells(Index, i).FormulaR1C1 = "=" & TempSheet.Cells((Index + 10), arrz(i - 20)).Address(True, True, xlR1C1, True)
        currentSheet.Cells((Index + 7), i).FormulaR1C1 = "=" & TempSheet.Cells((Index + 21), arrz(i - 20)).Address(True, True, xlR1C1, True)
        Next i
Next Index
End Sub

Отредактировано в соответствии с комментариями: добавлен инструмент выбора файлов и соответствующие ссылки на листы для них.Проверено и работает на моей машине.