CODEWITHSUNDEEP
excelvba
Christian
Christian

Reputation: 29

VBA Loop for filling worksheet

I need to copy data into a template but I am unsure how I create one line that includes all ranges and cells to make my code smaller. Right now I use 13 lines to fill out one of 20 products in the template. Can anyone help with this? Much appreciated

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

NEW EDIT:

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

Upvotes: 0

Views: 78

Answers (2)

Plutian
Plutian

Reputation: 2309

I opted to do the two blocks in a single loop instead with some maths, and also to dim the worksheets so they work with my test. Obviously you change these to the sheets you need.

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

Edited as per comments: added file picker and proper sheet references for such. Tested and works on my machine.

Upvotes: 0

riskypenguin
riskypenguin

Reputation: 2199

This should work for what you're asking, looks a bit cleaner:

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

Upvotes: 1

Related Questions