使用相同的代码遍历多个范围

Question

我是VBA的新手，我想寻求帮助。 我想清除代码，因为我对多个范围使用相同的循环代码。

我有表格，我有 10 张表格(位于下面的 2 列 x 5 中(。每个表最多可以包含 5 行，并有 4 列 (5x4(。

我想通过 vba 从新工作表中的表中导入输入。 所以我为某些范围创建了一个循环。范围是(54：58,65：69,76：80,87：91,98：102(，列(3-6(和(9-12( 我不想导入空白字段，因此有一个条件 if。

有没有办法简化代码，我不必循环每个范围？ 像"循环这些范围"并且只有一次代码

？

Dim wb As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim p As Long, i As Long
Dim lastrowPest As Long, lastrowField As Long
Set wb = ActiveWorkbook
Set wsSource = wb.Sheets("Field entry - plan")
Set wsTarget = wb.Sheets("List3")

lastrowField = wsSource.Cells(Rows.Count, 20).End(xlUp).row
For p = 54 To 58
For i = 3 To lastrowField
If wsSource.Cells(p, 4) <> "" Then
lastrowPest = wsTarget.Cells(Rows.Count, 24).End(xlUp).Offset(1, 0).row
wsSource.Range(wsSource.Cells(i, 20), wsSource.Cells(i, 20)).copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 24), wsTarget.Cells(lastrowPest, 24)).PasteSpecial Paste:=xlPasteValues
wsSource.Range(wsSource.Cells(i, 34), wsSource.Cells(i, 34)).copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 30), wsTarget.Cells(lastrowPest, 30)).PasteSpecial Paste:=xlPasteValues
wsSource.Range(wsSource.Cells(p, 3), wsSource.Cells(p, 6)).copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 26), wsTarget.Cells(lastrowPest, 28)).PasteSpecial Paste:=xlPasteValues
End If
If wsSource.Cells(p, 10) <> "" Then
lastrowPest = wsTarget.Cells(Rows.Count, 24).End(xlUp).Offset(1, 0).row
wsSource.Range(wsSource.Cells(i, 20), wsSource.Cells(i, 20)).copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 24), wsTarget.Cells(lastrowPest, 24)).PasteSpecial Paste:=xlPasteValues
wsSource.Range(wsSource.Cells(i, 34), wsSource.Cells(i, 34)).copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 30), wsTarget.Cells(lastrowPest, 30)).PasteSpecial Paste:=xlPasteValues
wsSource.Range(wsSource.Cells(p, 9), wsSource.Cells(p, 12)).copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 26), wsTarget.Cells(lastrowPest, 28)).PasteSpecial Paste:=xlPasteValues
End If
Next i
Next p

For p = 65 To 69
For i = 3 To lastrowField
If wsSource.Cells(p, 4) <> "" Then
lastrowPest = wsTarget.Cells(Rows.Count, 24).End(xlUp).Offset(1, 0).row
wsSource.Range(wsSource.Cells(i, 20), wsSource.Cells(i, 20)).copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 24), wsTarget.Cells(lastrowPest, 24)).PasteSpecial Paste:=xlPasteValues
wsSource.Range(wsSource.Cells(i, 34), wsSource.Cells(i, 34)).copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 30), wsTarget.Cells(lastrowPest, 30)).PasteSpecial Paste:=xlPasteValues
wsSource.Range(wsSource.Cells(p, 3), wsSource.Cells(p, 6)).copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 26), wsTarget.Cells(lastrowPest, 28)).PasteSpecial Paste:=xlPasteValues
End If
If wsSource.Cells(p, 10) <> "" Then
lastrowPest = wsTarget.Cells(Rows.Count, 24).End(xlUp).Offset(1, 0).row
wsSource.Range(wsSource.Cells(i, 20), wsSource.Cells(i, 20)).copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 24), wsTarget.Cells(lastrowPest, 24)).PasteSpecial Paste:=xlPasteValues
wsSource.Range(wsSource.Cells(i, 34), wsSource.Cells(i, 34)).copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 30), wsTarget.Cells(lastrowPest, 30)).PasteSpecial Paste:=xlPasteValues
wsSource.Range(wsSource.Cells(p, 9), wsSource.Cells(p, 12)).copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 26), wsTarget.Cells(lastrowPest, 28)).PasteSpecial Paste:=xlPasteValues
End If
Next i
Next p

Answer 1

您可以将重复代码放在不同的过程中，并使用如下参数调用它：

Option Explicit
Sub Test()
Dim FirstRows(1 To 2) As Long
FirstRows(1) = 54
FirstRows(2) = 65
Dim LastRows(1 To 2) As Long
LastRows(1) = 58
LastRows(2) = 69
Dim i As Long
For i = LBound(FirstRows) To UBound(FirstRows)
CopyPaste FirstRows(i), LastRows(i)
Next i
End Sub
Private Sub CopyPaste(FirstRow As Long, LastRow As Long)

Dim wb As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim p As Long, i As Long
Dim lastrowPest As Long, lastrowField As Long
Set wb = ActiveWorkbook
Set wsSource = wb.Sheets("Field entry - plan")
Set wsTarget = wb.Sheets("List3")

lastrowField = wsSource.Cells(Rows.Count, 20).End(xlUp).Row

For p = FirstRow To LastRow
For i = 3 To lastrowField
If wsSource.Cells(p, 4) <> "" Then
lastrowPest = wsTarget.Cells(Rows.Count, 24).End(xlUp).Offset(1, 0).Row
wsSource.Range(wsSource.Cells(i, 20), wsSource.Cells(i, 20)).Copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 24), wsTarget.Cells(lastrowPest, 24)).PasteSpecial Paste:=xlPasteValues
wsSource.Range(wsSource.Cells(i, 34), wsSource.Cells(i, 34)).Copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 30), wsTarget.Cells(lastrowPest, 30)).PasteSpecial Paste:=xlPasteValues
wsSource.Range(wsSource.Cells(p, 3), wsSource.Cells(p, 6)).Copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 26), wsTarget.Cells(lastrowPest, 28)).PasteSpecial Paste:=xlPasteValues
End If
If wsSource.Cells(p, 10) <> "" Then
lastrowPest = wsTarget.Cells(Rows.Count, 24).End(xlUp).Offset(1, 0).Row
wsSource.Range(wsSource.Cells(i, 20), wsSource.Cells(i, 20)).Copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 24), wsTarget.Cells(lastrowPest, 24)).PasteSpecial Paste:=xlPasteValues
wsSource.Range(wsSource.Cells(i, 34), wsSource.Cells(i, 34)).Copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 30), wsTarget.Cells(lastrowPest, 30)).PasteSpecial Paste:=xlPasteValues
wsSource.Range(wsSource.Cells(p, 9), wsSource.Cells(p, 12)).Copy
wsTarget.Range(wsTarget.Cells(lastrowPest, 26), wsTarget.Cells(lastrowPest, 28)).PasteSpecial Paste:=xlPasteValues
End If
Next i
Next p
End Sub

您可以通过将1 to 2更改为1 to whatever number并使其适合您的需要，在Test过程中放大阵列。