how to shorten my code

Question

I would like someone to look at my code and advice if there is any way to shorten it? Maybe another function that can be used?

The macro copies cells from one worksheet ("macro") to the first empty row in another worksheet ("tracker"). For instance the cell L1 in "macro" needs to be copied to first empty row in column A in "tracker" etc.

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

Please note that I am new in macros and VBA and I used this code because it works prety well, however it takes some time to copy everything.

Regards,

http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros — Vincent G, Jul 20 '17 at 12:24

score 0 · Answer 1 · answered Jul 20 '17 at 12:17

You can get rid of a lot of your selection statements. For example, try this for your first copy/paste

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

CLR · Accepted Answer · 2017-07-20T13:04:38.827

I'd do something like this, allowing you to add new from/to ranges simply by adding them to the arrays:

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

I tried to run your code but in line lMaxRows = .Cells(.Rows.Count, pasteto(myLoop)).End(xlUp).Row compile error occurs: "Variable is not defined" — Adrian, Jul 20 '17 at 12:59
You must have `Option Explicit` set, whereas it wasn't before. Add `Dim lMaxRows As Long` to the DIM declarations to declare it. (I'll add this to my answer) — CLR, Jul 20 '17 at 13:04

score 0 · Answer 3 · answered Jul 20 '17 at 12:29

You should always declare the worksheet variables that will require less typing and make the code cleaner.

So in your sub routine, declare the sheet variables like below...

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

Now your first two copy/paste blocks can be shortened as below. Change all other blocks exactly in the same way...

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

And in the end, don't forget to use the following line to clear the application clipboard.

Application.CutCopyMode = 0

score 0 · Answer 4 · edited Sep 20 '17 at 21:32

Here are some updates using VBA Best Practices:

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

thank you for the code and for link to VBA best practices – Adrian Jul 20 '17 at 13:19 — Adrian, Jul 20 '17 at 13:19

how to shorten my code

4 Answers4