如何缩短我的代码

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

宏将单元格从一个工作表（“宏”）复制到另一个工作表（“跟踪器”）中的第一个空行。例如，在“宏”单元L1需要“跟踪器”等被复制到第一个空行中列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新我用这个代码，因为它工作良好，但需要一些时间才能复制所有内容。

Regards，

来源

2017-07-20 Adrian

问它在http://codereview.stackexchange.com – Jens

http://stackoverflow.com/questions/10714251/how-to -avoid-using-select-in-excel-vba-macros –

不使用'.select'？ –

我会做这样的事情，让您可以从/添加新的范围仅仅通过将它们添加到阵列：

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

来源

2017-07-20 12:28:33 CLR

我试图运行你的代码，但行lMaxRows = .Cells（.Rows.Count，pasteto（myLoop））。结束（xlUp）.Row编译错误发生：“变量未定义” – Adrian

你必须有'Option Explicit'设置，而不是之前。向DIM声明中添加“Dim lMaxRows As Long”来声明它。（我会添加到我的答案） – CLR

它的工作，非常感谢。 – Adrian

你可以摆脱很多你的选择陈述。例如，尝试一下本作你的第一个复制/粘贴

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

来源

2017-07-20 12:17:23

感谢您的代码 – Adrian

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

所以在你的子过程，声明表变量，如下面...

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

来源

2017-07-20 12:29:08 sktneer

谢谢你的代码 – Adrian

不客气！阿德里安！ – sktneer

下面是使用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

来源

2017-07-20 12:54:58 sourceCode

感谢您的代码和链接到VBA最佳实践 – Adrian

如何缩短我的代码

回答

相关问题