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

Задача состоит в том, чтобы скопировать определенный диапазон текущего листа, открыть другую книгу, и вставить эти скопированные данные в определенную ячейку, сохранить этот файл и закрыть. Ниже приведен код VBA.

Sub Название_Макроса()

'Выделить диапазон который необходимо скопировать
Range("A1:F52").Select
'Скопировать то, что выделено
Selection.Copy
ChDir "путь к папке где лежит файл в который необходимо скопировать"
Workbooks.Open Filename:= "Название файла, который находится в папке, путь к которой указан выше"
'Выделить начальную ячейку в которую необходимо вставить скопированные данные
Range("A6").Select
'Вставить данные
ActiveSheet.Paste
'сохранить текущую книгу
ActiveWorkbook.Save
'Закрыть книгу
ActiveWorkbook.Close
End Sub

Вариант 2: В открывшейся книге запускаем макрос, чтобы он открыл нужную нам книгу, скопировал от туда нужные нам данные и вставил в нашу открытую книгу, закрыв файл из которого эти данные были скопированы

Sub Название_Макроса2()
'Открываем файл с которого нужно скопировать данные
Workbooks.Open Filename:="C:Данные.xlsx"

'Скопировать нужный диапазон в открывшейся книге на листе 1
Workbooks("Данные.xlsx").Worksheets("Лист1").Range("A16:E16").Copy
'Активируем нужную нам книгу
Workbooks("Книга1.xlsm").Activate

'Выделяем и вставляем скопированные данные в ячейку А1
ActiveWorkbook.Worksheets("Лист1").Range("A1").Select
ActiveSheet.Paste

'Закрываем книгу откуда мы скопировали данные
Workbooks("Данные.xlsx").Close

End Sub

Еще пример — Скопировать диапазоны данных из активной открытой книги Excel нескольких листов (в нашем примере 3-х листов) в другую книгу, которая хранится в определенном месте. Данные будут вставлены как значения, плюс будут перенесены форматы ячеек.

Sub Копируем_листы_в_другую_книгу()
Dim bookconst As Workbook
Dim abook As Workbook
Set abook = ActiveWorkbook 'присваиваем перменную активной книге
Set bookconst = Workbooks.Open("C:UsersUserDesktop1.xlsx") 'присваиваем перменную книге куда необходимо копировать данные

'переходим в активную книгу откуда необходимо скопировать данные
abook.Worksheets("Лист1").Activate
Range("A1:I23").Copy 'копируем определенный диапазон листа, укажите свой диапазон
bookconst.Worksheets("Лист1").Activate 'активируем лист куда необходимо вставить данные
Range("A1:I23").Select 'встаем на ячейку А1
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'вставляем только форматы ячеек
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'второй лист
abook.Worksheets("Лист2").Activate
Range("A1:I23").Copy
bookconst.Worksheets("Лист2").Activate
Range("A1:I23").Select 'выделяем диапазон
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'вставляем только форматы ячеек
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'третий лист
abook.Worksheets("Лист3").Activate
Range("A1:I23").Copy
bookconst.Worksheets("Лист3").Activate
Range("A1:I23").Select 'выделяем диапазон
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'вставляем только форматы ячеек
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'сохранить текущую книгу
bookconst.Save
'Закрыть книгу
bookconst.Close
abook.Activate

End Sub

Если статья была вам полезна, то буду благодарен, если вы поделитесь ей со своими друзьями с помощью кнопок расположенных ниже.

Спасибо за внимание.

I have two sheets containing the employee records.
Sheet1 contains the Event Date, CardNo, Employee Name, Dept Id, Employee No, Entry and Exit Time, Total Working Hours, Status, ConcatinatedColumn and Remarks (copied through vlookup from sheet2)

Sheet2 contains ConcatinatedColumn, Event Date, Employee No, Name, Remarks.

If the data in the remarks column of sheet2 is «Sick Off» then that row should be inserted to sheet1 without effecting the previous records.

I’ve already written the code for it but it does not work.

Would be really grateful if anyone can help me out !

THANKS IN ADVANCE !

MY CODE :

Sub SickOff()

Dim objWorksheet As Sheet2
Dim rngBurnDown As Range
Dim rngCell As Range
Dim strPasteToSheet As String

'Used for the new worksheet we are pasting into
Dim objNewSheet As Sheet1

Dim rngNextAvailbleRow As Range

'Define the worksheet with our data
Set objWorksheet = ThisWorkbook.Worksheets("Sheet2")


'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngBurnDown = objWorksheet.Range("G2:G" & objWorksheet.Cells(Rows.Count,       "G").End(xlUp).Row)

'Now loop through all the cells in the range
For Each rngCell In rngBurnDown.Cells

objWorksheet.Select

If rngCell.Value = "Sick Off" Then
'select the entire row
rngCell.EntireRow.Select

'copy the selection
Selection.Copy

'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Worksheets("Sheet1" & rngCell.Value)
objNewSheet.Select

'Looking at your initial question, I believe you are trying to find the next     available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)


Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
End If

Next rngCell

objWorksheet.Select
objWorksheet.Cells(1, 1).Select

'Can do some basic error handing here

'kill all objects
If IsObject(objWorksheet) Then Set objWorksheet = Nothing
If IsObject(rngBurnDown) Then Set rngBurnDown = Nothing
If IsObject(rngCell) Then Set rngCell = Nothing
If IsObject(objNewSheet) Then Set objNewSheet = Nothing
If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing

End Sub

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