Vba 如何缩短我的代码

我想有人看看我的代码和建议，如果有任何方法来缩短它？也许可以使用另一个功能

宏将单元格从一个工作表（“宏”）复制到另一个工作表（“跟踪器”）的第一个空行。例如，“宏”中的单元格L1需要复制到“跟踪器”中A列的第一个空行中

请注意，我对宏和VBA是新手，我使用这段代码是因为它工作得很好，但是复制所有内容需要一些时间

---

在这方面，

您可以去掉很多选择语句。例如，在第一次复制/粘贴时尝试此操作

Sheets("macro").Range("L1").Copy
lMaxRows = Sheets("Tracker").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Tracker").Range("A" & lMaxRows + 1).PasteSpecial xlPasteValues

---

我会这样做，只需将新的from/to范围添加到数组中，就可以添加新的from/to范围：

Sub tracker_update()

Application.ScreenUpdating = False

Dim myLoop As Integer
Dim copyfrom As Variant
Dim pasteto As Variant
Dim sourceSht As Worksheet
Dim targetSht As Worksheet
Dim lMaxRows As Long

Set sourceSht = Sheets("macro")
Set targetSht = Sheets("Tracker")

sourceSht.Range("D4") = "name"
sourceSht.Range("C10") = "n"


copyfrom = Split("L1,B6,D4,B3,B5,B7,B10,C10,C10,L2,L4,L5", ",")
pasteto = Split("A,B,C,D,H,I,K,M,L,E,F,G", ",")

For myLoop = 0 To UBound(copyfrom)
    sourceSht.Range(copyfrom(myLoop)).Copy
    With targetSht
        lMaxRows = .Cells(.Rows.Count, pasteto(myLoop)).End(xlUp).Row
        .Range(pasteto(myLoop) & lMaxRows + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    End With
Next

With sourceSht
    .Range("A:H").Clear
    .Columns("A:H").ColumnWidth = 8.43
    .Rows("1:100").RowHeight = 15
End With

Application.ScreenUpdating = False

End Sub

---

您应该始终声明工作表变量，这些变量将需要更少的键入并使代码更干净

因此，在您的子程序中，声明如下所示的工作表变量

Dim sws As Worksheet, dws As Worksheet
Set sws = Sheets("macro")
Set dws = Sheets("Tracker")

现在，您的前两个复制/粘贴块可以缩短，如下所示。以相同的方式更改所有其他块

sws.Range("L1").Copy
dws.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues

sws.Range("B6").Copy
dws.Range("B" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues

最后，不要忘记使用下面的行来清除应用程序剪贴板

Application.CutCopyMode = 0

---

以下是使用VBA最佳实践的一些更新：

Sub tracker_update()

Dim array1(10) As String, array2(10) As String, i As Integer

array1(0) = "L1": array1(1) = "B6": array1(2) = "D4": array1(3) = "B3": array1(4) = "B5": array1(5) = "B7": array1(6) = "B10": array1(7) = "C10": array1(8) = "L2": array1(9) = "L4": array1(10) = "L5"
array2(0) = "A": array2(1) = "B": array2(2) = "C": array2(3) = "D": array2(4) = "H": array2(5) = "I": array2(6) = "K": array2(7) = "M": array2(8) = "L": array2(9) = "E": array2(10) = "F": array2(10) = "G"

'turn off screen updating and popup alerts
Application.ScreenUpdating = False 'turn off screen updating (don't show screen)
Application.DisplayAlerts = False 'turn off popup alerts

Worksheets("macro").Range("D4").Value = "name"
Worksheets("macro").Range("C10").Value = "n"

For i = 0 To UBound(array1)
    Sheets("Tracker").Range(array2(i) & findLastRow(array2(i), "Tracker")).Value = Sheets("macro").Range(array1(i)).Value
Next i

'Clean up
With Sheets("macro")
    .Range("A:H").Clear
    .Columns("A:H").ColumnWidth = 8.43
    .Rows("1:100").RowHeight = 15
End With

'turn off screen updating and popup alerts
Application.ScreenUpdating = True 'turn on screen updating (don't show screen)
Application.DisplayAlerts = True 'turn on popup alerts

End Sub


Function findLastRow(ByVal col As String, ByVal sht As String) As Integer
    findLastRow = Sheets(sht).Range(col & Sheets(sht).Rows.Count).End(xlUp).Row + 1 'get last row that is empty

End Function

---

请不要使用

。选择
？？我试图运行您的代码，但行lMaxRows=.Cells（.Rows.Count，paseto（myLoop））.End（xlUp）。行编译错误发生：“变量未定义”您必须设置
选项Explicit
，而之前没有设置。将
Dim lMaxRows添加到Dim声明中以声明它。（我将把这个添加到我的答案中）感谢您提供代码和指向VBA最佳实践的链接
Sub tracker_update()

Dim array1(10) As String, array2(10) As String, i As Integer

array1(0) = "L1": array1(1) = "B6": array1(2) = "D4": array1(3) = "B3": array1(4) = "B5": array1(5) = "B7": array1(6) = "B10": array1(7) = "C10": array1(8) = "L2": array1(9) = "L4": array1(10) = "L5"
array2(0) = "A": array2(1) = "B": array2(2) = "C": array2(3) = "D": array2(4) = "H": array2(5) = "I": array2(6) = "K": array2(7) = "M": array2(8) = "L": array2(9) = "E": array2(10) = "F": array2(10) = "G"

'turn off screen updating and popup alerts
Application.ScreenUpdating = False 'turn off screen updating (don't show screen)
Application.DisplayAlerts = False 'turn off popup alerts

Worksheets("macro").Range("D4").Value = "name"
Worksheets("macro").Range("C10").Value = "n"

For i = 0 To UBound(array1)
    Sheets("Tracker").Range(array2(i) & findLastRow(array2(i), "Tracker")).Value = Sheets("macro").Range(array1(i)).Value
Next i

'Clean up
With Sheets("macro")
    .Range("A:H").Clear
    .Columns("A:H").ColumnWidth = 8.43
    .Rows("1:100").RowHeight = 15
End With

'turn off screen updating and popup alerts
Application.ScreenUpdating = True 'turn on screen updating (don't show screen)
Application.DisplayAlerts = True 'turn on popup alerts

End Sub


Function findLastRow(ByVal col As String, ByVal sht As String) As Integer
    findLastRow = Sheets(sht).Range(col & Sheets(sht).Rows.Count).End(xlUp).Row + 1 'get last row that is empty

End Function