用于填充工作表的VBA循环

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

根据注释进行编辑：为此添加了文件选择器和适当的工作表引用。在我的机器上测试并工作。