Copy and past information between sheets efficiently

Question

I have the following VBA code in excel that basically update the data in sheet 1 and then copy paste information one by one from sheet1 to sheet2. It works fine but the problem is that it takes a bit longer than normal to run. Is there a way to make this code more efficient?

Sub test()

Dim str As Integer
Dim ctr As Integer
ctr = 1

Sheets("Sheet1").Select
str = Range("A1", Range("A1").End(xlDown)).Rows.Count
str = str + 1

Worksheets("Sheet2").Range("A2:c5000").Clear

While ctr < str

    Sheets("Sheet1").Select
    Range("A" & counter).Copy Range("E1")
    Range("K4").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A" & Rows.Count).End(xlUp).Offset(1).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    ctr = ctr + 1
Wend


End Sub

Refer [This](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba/22080453?r=SearchResults#22080453) — Dy.Lee, Feb 25 '21 at 05:29
Your code has a loop which repeats itself as many times as there are rows in Sheet1. On each loop, the value from column A is written to E1. Therefore E1 changes rapidly and will end up showing the value from the last loop. Then, everything from K4 to left and down is copied to the bottom of Sheet2. This source range never changes. Therefore you will get multiple copies of it on Sheet2. — Variatus, Feb 25 '21 at 06:06

Variatus · Answer 1 · 2021-02-25T07:09:11.390

Here's a re-write of your code, warts (as mentioned in my comment above) and all, meaning no improvement of its functionality.

Sub Test_2()

    ' declare row numbers as Long because the Integer data type can't
    ' hold the value of the last row number in a sheet
    Dim R       As Long         ' loop counter: Row
    Dim Rng     As Range        ' loop object:
    Dim Rcount  As Long         ' Rows: count
    Dim Ccount  As Long         ' Columns: count
    
    ' No need to Select anything
    Sheet2.Columns("A:C").ClearContents
    
    ' use a For / Next loop to call up each row number
    '    Next R advances R to the next integer
    For R = 1 To Sheet1.Range("A1", Range("A1").End(xlDown)).Rows.Count
    
        ' (not useful but instructive)
        Sheet1.Range("E1").Value = Sheet1.Cells(R, "A").Value
        
        ' Range("K4") is difficult to handle in a loop.
        ' Better use Cells(4, "K") and better still, Cells(4, 11)
        '   where both 4 and 11 can be calculatable variables.
        ' Here the range is fixed to K4 and can't change in the loop.
        Ccount = Sheet1.Range("K4").End(xlToRight).Column - Columns("K").Column + 1
        Rcount = Sheet1.Range("K4").End(xlDown).Row - Range("K4").Row + 1
        Set Rng = Sheet1.Cells(4, "K").Resize(Rcount, Ccount)
'        Debug.Print Rng.Address ' check the address of the range created

        Rng.Copy Destination:=Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Offset(1)
    Next R
End Sub

Now, having dispensed with Select, please give your attention to the With statement. It further simplifies the code by avoiding repetitions of qualifiers. Using that technique the last line of the above procedure would appear as shown below. The repetitive "Sheet2" is replaced with a leading period on each use.

With Sheet2
    Rng.Copy Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(1)
End With

I'm not confident that you really want to use xlDown in determining the range dimensions. I did change it to xlUp in determining the destination cell and would change it for setting the end of the For / Next loop, too because as the code is now it will fail (because of the xlDown) if A1 is blank. Better read up on the difference between xlDown and xlUp in this context. As a hint, xlDown looks from the start cell downward until it finds a blank, while xlUp looks from the start cell upward to find a non-blank. So, xlDown will find the first blank cell following the start cell and return the cell above that, while xlUp will find the first non-blank cell (usually from the last row in the sheet) and return it. Similarly, for xlToLeft and xlToRight.

JohnnieL · Answer 2 · 2021-02-25T08:24:47.767

FYI Range("A" & counter).Copy Range("E1") - counter doesnt exist - piece of advice, always use option explicit.

Another piece of advice never use select unless you are doing UI stuff - try to do it with range variables (fully qualified, see this)

Application.ScreenUpdating = False is helpful to speed things up and make things look better if there is a lot of flicker. That said the original code probably costs a lot of time with the selecting - none of which is necessary.

Also your original code is making calculations inside the loop that give the same result every time i guess if the shape of the result anchored at k4 never changes

Sub test()

Application.ScreenUpdating = False

dim ws_in as worksheet
set ws_in=Thisworkbook.Worksheets("Sheet1")
dim ws_out as worksheet
set ws_out = Thisworkbook.Worksheets("Sheet2")
ws_out.Range("A2:c5000").Clear

Dim result_range As Range
Set result_range = Range(ws_in.Range("k4"), ws_in.Range("k4").End(xlToRight).End(xlDown))

Dim output_range As Range
Set output_range = ws_out.Range("A" & Rows.Count).End(xlUp).Offset(1)

Dim r As Range

For Each r In Range(ws_in.Range("A1"), ws_in.Range("A1").End(xlDown))
  ws_in.Range("e1").Value = r.Value
  result_range.copy
  output_range.PasteSpecial Paste:=xlPasteValues
  Set output_range = output_range.Offset(result_range.Rows.Count, 0)
Next r

Application.ScreenUpdating = True

End Sub

A couple of notes (1) you can chain .End (2) you can use CurrentRegion to identify an "island" of cells - i dont know how the rest of the sheet is constructed but range("k4").currentregion may be an option

Copy and past information between sheets efficiently

2 Answers2