如何缩短我的代码

时间：2017-07-20 12:08:31

标签： excel vba excel-vba

如果有什么方法可以缩短它，我希望有人看看我的代码和建议吗？也许可以使用其他功能？

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

Sub tracker_update()

Application.ScreenUpdating = False

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

Sheets("macro").Select
Range("L1").Select
Selection.Copy
Sheets("Tracker").Select
lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
Range("A" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Sheets("macro").Select
Range("B6").Select
Selection.Copy
Sheets("Tracker").Select
lMaxRows = Cells(Rows.Count, "B").End(xlUp).Row
Range("B" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Sheets("macro").Select
Range("D4").Select
Selection.Copy
Sheets("Tracker").Select
lMaxRows = Cells(Rows.Count, "C").End(xlUp).Row
Range("C" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Sheets("macro").Select
Range("B3").Select
Selection.Copy
Sheets("Tracker").Select
lMaxRows = Cells(Rows.Count, "D").End(xlUp).Row
Range("D" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Sheets("macro").Select
Range("B5").Select
Selection.Copy
Sheets("Tracker").Select
lMaxRows = Cells(Rows.Count, "H").End(xlUp).Row
Range("H" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Sheets("macro").Select
Range("B7").Select
Selection.Copy
Sheets("Tracker").Select
lMaxRows = Cells(Rows.Count, "I").End(xlUp).Row
Range("I" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Sheets("macro").Select
Range("B10").Select
Selection.Copy
Sheets("Tracker").Select
lMaxRows = Cells(Rows.Count, "K").End(xlUp).Row
Range("K" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Sheets("macro").Select
Range("C10").Select
Selection.Copy
Sheets("Tracker").Select
lMaxRows = Cells(Rows.Count, "M").End(xlUp).Row
Range("M" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Sheets("macro").Select
Range("C10").Select
Selection.Copy
Sheets("Tracker").Select
lMaxRows = Cells(Rows.Count, "L").End(xlUp).Row
Range("L" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Sheets("macro").Select
Range("L2").Select
Selection.Copy
Sheets("Tracker").Select
lMaxRows = Cells(Rows.Count, "E").End(xlUp).Row
Range("E" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Sheets("macro").Select
Range("L4").Select
Selection.Copy
Sheets("Tracker").Select
lMaxRows = Cells(Rows.Count, "F").End(xlUp).Row
Range("F" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Sheets("macro").Select
Range("L5").Select
Selection.Copy
Sheets("Tracker").Select
lMaxRows = Cells(Rows.Count, "G").End(xlUp).Row
Range("G" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Sheets("macro").Select
Range("A:H").Clear
Columns("A:H").ColumnWidth = 8.43
Rows("1:100").RowHeight = 15

Application.ScreenUpdating = False

End Sub

请注意我是宏和VBA的新手，我使用这段代码因为它很好用，但是复制一切需要一些时间。

此致

4 个答案:

答案 0 :(得分：0)

你可以摆脱很多选择陈述。例如，尝试使用此功能进行首次复制/粘贴

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

答案 1 :(得分：0)

我做了类似的事情，只需将它们添加到数组中，就可以添加新的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

答案 2 :(得分：0)

您应该始终声明需要较少输入的工作表变量，并使代码更清晰。

因此，在子例程中，声明下面的工作表变量...... 

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

答案 3 :(得分：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
相关问题
最新问题