Копирование одного листа на другой лист в excel vba

Introduction

This tip shows 2 ways to copy data between Excel sheets in the same workbook using VBA.

Background

Most beginners in VBA programming make several mistakes, which are commonly named: bad practice. What is bad practice in Excel-VBA from my point of view?

• Using code without context, for example:

  Range("A1") = "Some Text"
  
  Cells(5,5) = 125

  Imagine, you wanted to insert those values into Sheet2, but when a code has been executed, Sheet1 was active. Where the data has been written? Of course, into Sheet1.

• Using Select and Activate method

  This might be the reason for several issues, such as unnecessary calculations.
• Using undefined variables (not explicitly declared as some other type)

  In that case, every variable consumes more memory than is necessary, because of type of variant.
  See Data types
• Using code without error handling

For further details, please see: Excel VBA Performance Coding Best Practices

Let’s say you want to copy some portion of data from Sheet1 into Sheet2. A condition is defined as: Level has to be greater than 1 (see image below).

Using the code

Solution #1 — Using ADODB.Recordset and Range.CopyFromRecordset Method

This method is really quick!

Note: Before you run below code, you have to add a reference to Microsoft ActiveX Data Object Library x.x. How? Check or Add an Object Library Reference

Please, check out below code (Excel 2007 ad higher). Do not forget to read my comments.

Sub CopyData1()
Dim oConn As ADODB.Connection, oRst As ADODB.Recordset
Dim sConn As String, sSql As String

On Error GoTo Err_CopyData1


sConn = "Provider=Microsoft.ACE.OLEDB.12.0;_
Data Source=" & ThisWorkbook.FullName & ";_
         Extended Properties='Excel 12.0 Macro;HDR=YES';"

Set oConn = New ADODB.Connection
With oConn
    .ConnectionString = sConn
    .Open
End With

sSql = "SELECT [Part_Number], [Name], [Version], [Level]" & vbCr & _
    "FROM [Sheet1$A1:D100]" & vbCr & _
    "WHERE [Level]>1;"

Set oRst = New ADODB.Recordset
oRst.Open sSql, oConn, adOpenStatic, adLockReadOnly


With ThisWorkbook.Worksheets("Sheet2")
    
    .Range("A2:D10000").Delete xlShiftUp
    
    .Range("A2").CopyFromRecordset oRst
End With


Exit_CopyData1:
    
    On Error Resume Next
    If Not oConn Is Nothing Then oConn.Close
    Set oConn = Nothing
    If Not oRst Is Nothing Then oRst.Close
    Set oRst = Nothing
    Exit Sub


Err_CopyData1:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_CopyData1
End Sub

For further details, please see:

• ADODB.Recordset
• Range.CopyFromRecordset

In case you want to fetch data from another type of workbook or you want to refer to earlier version of MS Excel files, you have to change connection string. See: Excel — OleDb 12.0 connection strings

If you would like to know, how to copy data into new or existing Sheet in different workbook, please find related content below.

Solution #2 — Using Do/While..Loop or For…Next Loop

Sub CopyData2()
Dim srcWsh As Worksheet, dstWsh As Worksheet
Dim i As Integer, j As Integer

On Error GoTo Err_CopyData2


Set srcWsh = ThisWorkbook.Worksheets("Sheet1")
Set dstWsh = ThisWorkbook.Worksheets("Sheet2")


dstWsh.Range("A2:D10000").Clear


i = 2
j = 2

Do While srcWsh.Range("A" & i) <> ""
    
    If srcWsh.Range("D" & i) = 1 Then GoTo SkipThisRow
    
    With dstWsh
        .Range("A" & j) = srcWsh.Range("A" & i)
        .Range("B" & j) = srcWsh.Range("B" & i)
        .Range("C" & j) = srcWsh.Range("C" & i)
        .Range("D" & j) = srcWsh.Range("D" & i)
    End With
    
    j = j + 1

SkipThisRow:
    
    i = i + 1
Loop

Exit_CopyData2:
    On Error Resume Next
    Set srcWsh = Nothing
    Set dstWsh = Nothing
    Exit Sub

Err_CopyData2:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_CopyData2
End Sub

You may want to ask me: Why a set of columns has been hard-coded in above example?

The answer is pretty easy. You may want to copy data in defferent order or into different range.

Other solutions

Using Filter-And-Copy

Sub FilterAndCopy()
    Dim srcWsh As Worksheet
    Dim dstWsh As Worksheet
    
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
    
    On Error GoTo Err_FilterAndCopy
    
    
    dstWsh.Range("A2:A10000").Clear  
    
    With srcWsh
        .Range("A1").AutoFilter  
        .UsedRange.AutoFilter Field:=4, Criteria1:=">1"
        
        .UsedRange.Copy Destination:=dstWsh.Range("A2")
    End With
    
    Application.CutCopyMode = False
    srcWsh.Range("A1").AutoFilter  
 
Exit_FilterAndCopy:
    On Error Resume Next
    Set srcWsh = Nothing
    Set dstWsh = Nothing
    Exit Sub

Err_FilterAndCopy:
    MsgBox Err.Description, vbCritical, Err.Number
    Resume Exit_FilterAndCopy
End Sub

Above method is pretty good, but has several limitations. The main issue is copying a large portion of data. When you copy simple data (no formulas), it can take a while for the operation to complete. But when you’re copying the data containing set of formulas, then the time needed to complete operation may increase several times due an Excel have to perform thousands of calculations…

Copy data into new worksheet/workbook or into existing sheet in different workbook

This is quite easy. Depending on situation (workbook is already open or not), you have to change only one line or few lines.

Set dstWsh = Workbooks("ShortNameOfWorkbook.xlsx").WorkSheets("DestinationSheet")



Workbooks.Open "FullPathAndNameOfWorkbook.xlsx"
Set dstWsh = ActiveWorkbook.Worksheets("DestinationSheet")

Final Note

I hope you’ve learned how to copy data between sheets and workbooks.

History

• 2017-05-23 — Added: other solutions and information about copying data into new or existing workbook/worksheet
• 2017-05-17 — Initial version