Copy and paste to another workbook without overwrite data

J

Jirka79

New Member
Joined
Dec 9, 2020
Messages
32
Office Version
  1. 2010
Platform
  1. Windows
Dear all,

I have a Workbook called Data.xlsx with sheet1 containing data in columns A to G. This data is growing daily by the operators, meaning that everyday new rows are added.

What I would like, is to take ONLY the new data added since the last time and copy it to another Workbook called ALLData.xlsm in the sheet "DailyData"

In column A operators are entering a unique value that is never repeated. So, I would like a macro that takes the last value entered in column A in the workbook "ALLData.xlsm" and goes to the Workbook Data.xls, search for this last value and copy the next new rows from column A to G that were recently added and paste them to ALLData.xlsm

I know it could be easily done copying and pasting every time the range A1:G999999, but I dont want to always overwrite all the data, I just want to add the new rows as per the last time I updated my file.

Can somebody help me with this issue please?

Thanks you all in advance!

PD: My actual code is such a mess because I'm completely lost... it also should copy the rows containing "X" in the column H... but this could be omitted...

VBA Code: 
Sub transDATA()
Dim StRo As Integer, T As Integer, Ro2 As Integer, Lr As Integer

Application.ScreenUpdating = False
Application.EnableEvents = False
Workbooks("Data.xlsx").Activate
Worksheets("sheet1").Activate
With Sheets("sheet1")
M = Workbooks("ALLDATA.xlsm").Worksheets("DailyData").UsedRange.Rows.Count

If Workbooks("ALLDATA.xlsm").Worksheets("DailyData").UsedRange.Rows.Count = 1 Then
.Range("A1:G1").Copy 
Workbooks("ALLDATA.xlsm").Worksheets("DailyData").Range("A1")
StRo = .Range("H:H").Find("X").Row
Lr = 1
Else
Lr = Workbooks("ALLDATA.xlsm").Worksheets("DailyData").Range("A" & Rows.Count).End(xlUp).Row
StRo = .Range("A:A").Find(Workbooks("ALLDATA.xlsm").Worksheets("DailyData").Range("A" & Lr)).Row + 1
End If

For T = StRo To .Range("A" & Rows.Count).End(xlUp).Row
If .Range("H" & T) = "X" Then
Ro2 = Ro2 + 1
Workbooks("ALLDATA.xlsm").Worksheets("DailyData").Range("A" & Lr + Ro2 & ":G" & Lr + Ro2).Value = .Range("A" & T & ":G" & T).Value
End If
  
Next T

End With
Application.ScreenUpdating = True
Application.EnableEvents = True

Workbooks("ALLDATA.xlsm").Worksheets("DailyData").Activate

End Sub
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Sort by date Sort by votes
This should work. A little fiddling may be needed.

VBA Code: 
Sub copyFunction()
  Dim lRow1 As Integer
  Dim lRow2 As Integer
  Dim j As Integer
  Dim lValue As String
  j = 1
  lRow1 = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
  lValue = Cells(lRow1, 1).Value

  lRow2 = Workbooks("ALLDATA.xlsm").Worksheets("DailyData").Cells(Rows.Count, 1).End(xlUp).Row

  For i =1 To lRow2
    If Workbooks("ALLDATA.xlsm").Worksheets("DailyData").Cells(i, 1).Value = lValue Then
      For ii = 1 To 7
        For iii = i+1 To lRow2
          Sheets("Sheet1").Cells(lRow1+j, ii).Value = Workbooks("ALLDATA.xlsm").Worksheets("DailyData").Cells(iii, ii).Value
          j = j + 1
        Next
      Next
      Exit For
    End If
  Next

End Sub
 
Upvote 0
Hi Jirka79,

what about
VBA Code: 
Sub MrE1218377()
'https://www.mrexcel.com/board/threads/copy-and-paste-to-another-workbook-without-overwrite-data.1218377/
Dim lngStart        As Long
Dim lngCounter      As Long
Dim wbkData         As Workbook
Dim wksData         As Worksheet
Dim wbkAll          As Workbook
Dim wksDaily        As Worksheet

Const clngNumCols As Long = 7

Application.ScreenUpdating = False
Application.EnableEvents = False

On Error Resume Next
Set wbkData = Workbooks("Data.xlsx")
On Error GoTo 0
If wbkData Is Nothing Then
  MsgBox "Please open Workbook 'Data.xlsx' and start the macro again", vbInformation, "Data workbook not open"
  GoTo leave_here
End If
Set wksData = wbkData.Worksheets("sheet1")

On Error Resume Next
Set wbkAll = Workbooks("ALLDATA.xlsm")
On Error GoTo 0
If wbkAll Is Nothing Then
  MsgBox "Please open Workbook 'ALLDATA.xlsm' and start the macro again", vbInformation, "Sampler workbook not open"
  GoTo leave_here
End If
Set wksDaily = wbkAll.Worksheets("DailyData")

With wksData
  If wksDaily.UsedRange.Rows.Count = 1 Then
    wksDaily.Range("A1").Resize(1, clngNumCols).Value = .Range("A1").Resize(1, clngNumCols).Value
  Else
    lngStart = .Range("A:A").Find(wksDaily.Range(Rows.Count, "A").End(xlUp).Value).Row + 1
  End If
  
  For lngCounter = lngStart To .Range("A" & Rows.Count).End(xlUp).Row
    If .Range("H" & lngCounter) = "X" Then
      wksDaily.Range("A" & Rows.Count).End(xlUp).Offset().Resize(1, clngNumCols).Value = .Range("A" & lngCounter).Resize(1, clngNumCols).Value
    End If
  Next lngCounter

End With

Application.Goto wksDaily.Range("A" & Rows.Count).End(xlUp)

leave_here:
Set wksDaily = Nothing
Set wbkAll = Nothing
Set wksData = Nothing
Set wbkData = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Ciao,
Holger
 
Upvote 0
HaHoBe said:
Hi Jirka79,

what about
VBA Code: 
Sub MrE1218377()
'https://www.mrexcel.com/board/threads/copy-and-paste-to-another-workbook-without-overwrite-data.1218377/
Dim lngStart        As Long
Dim lngCounter      As Long
Dim wbkData         As Workbook
Dim wksData         As Worksheet
Dim wbkAll          As Workbook
Dim wksDaily        As Worksheet

Const clngNumCols As Long = 7

Application.ScreenUpdating = False
Application.EnableEvents = False

On Error Resume Next
Set wbkData = Workbooks("Data.xlsx")
On Error GoTo 0
If wbkData Is Nothing Then
  MsgBox "Please open Workbook 'Data.xlsx' and start the macro again", vbInformation, "Data workbook not open"
  GoTo leave_here
End If
Set wksData = wbkData.Worksheets("sheet1")

On Error Resume Next
Set wbkAll = Workbooks("ALLDATA.xlsm")
On Error GoTo 0
If wbkAll Is Nothing Then
  MsgBox "Please open Workbook 'ALLDATA.xlsm' and start the macro again", vbInformation, "Sampler workbook not open"
  GoTo leave_here
End If
Set wksDaily = wbkAll.Worksheets("DailyData")

With wksData
  If wksDaily.UsedRange.Rows.Count = 1 Then
    wksDaily.Range("A1").Resize(1, clngNumCols).Value = .Range("A1").Resize(1, clngNumCols).Value
  Else
    lngStart = .Range("A:A").Find(wksDaily.Range(Rows.Count, "A").End(xlUp).Value).Row + 1
  End If
 
  For lngCounter = lngStart To .Range("A" & Rows.Count).End(xlUp).Row
    If .Range("H" & lngCounter) = "X" Then
      wksDaily.Range("A" & Rows.Count).End(xlUp).Offset().Resize(1, clngNumCols).Value = .Range("A" & lngCounter).Resize(1, clngNumCols).Value
    End If
  Next lngCounter

End With

Application.Goto wksDaily.Range("A" & Rows.Count).End(xlUp)

leave_here:
Set wksDaily = Nothing
Set wbkAll = Nothing
Set wksData = Nothing
Set wbkData = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Ciao,
Holger
Click to expand...
Hi Holger,

I get an error in this line:

VBA Code: 
lngStart = .Range("A:A").Find(wksDaily.Range(Rows.Count, "A").End(xlUp).Value).Row + 1

Run time 1004:
Method 'Range' of object '_Worksheet' failed
 
Upvote 0
Flashbond said:
This should work. A little fiddling may be needed.

VBA Code: 
Sub copyFunction()
  Dim lRow1 As Integer
  Dim lRow2 As Integer
  Dim j As Integer
  Dim lValue As String
  j = 1
  lRow1 = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
  lValue = Cells(lRow1, 1).Value

  lRow2 = Workbooks("ALLDATA.xlsm").Worksheets("DailyData").Cells(Rows.Count, 1).End(xlUp).Row

  For i =1 To lRow2
    If Workbooks("ALLDATA.xlsm").Worksheets("DailyData").Cells(i, 1).Value = lValue Then
      For ii = 1 To 7
        For iii = i+1 To lRow2
          Sheets("Sheet1").Cells(lRow1+j, ii).Value = Workbooks("ALLDATA.xlsm").Worksheets("DailyData").Cells(iii, ii).Value
          j = j + 1
        Next
      Next
      Exit For
    End If
  Next

End Sub
Click to expand...

Hi Flashbond,

Unfortunately your code doesn't make any reaction.... :/
 
Upvote 0
Jirka79 said:
Hi Flashbond,

Unfortunately your code doesn't make any reaction....
Click to expand...
My code won't work unless you have 1 record in Sheet1. Also try to cahnge this line
VBA Code: 
lValue = Cells(lRow1, 1).Value
To this
VBA Code: 
lValue = Sheets("Sheet1")Cells(lRow1, 1).Value
 
Upvote 0
Hi Jirka,

there were obviously a couple of errors in the first code supplied. Both workbooks need to be opened before the macro is run:
VBA Code: 
Sub MrE1218377_2()
'https://www.mrexcel.com/board/threads/copy-and-paste-to-another-workbook-without-overwrite-data.1218377/
Dim lngStart        As Long
Dim lngCounter      As Long
Dim wbkData         As Workbook
Dim wksData         As Worksheet
Dim wbkAll          As Workbook
Dim wksDaily        As Worksheet
Dim rngFound        As Range

Const clngNumCols As Long = 7

Application.ScreenUpdating = False
Application.EnableEvents = False

'/// code amended for the check of the proper sheets to be referenced
On Error Resume Next
Set wbkData = Workbooks("Data.xlsx")
If wbkData Is Nothing Then
  MsgBox "Please open Workbook 'Data.xlsx' and start the macro again", vbInformation, "Data workbook not open"
  GoTo leave_here
End If
Set wksData = wbkData.Worksheets("sheet1")
If wksData Is Nothing Then
  MsgBox "No sheet 'sheet1' found", vbInformation, "Data sheet not found"
  GoTo leave_here
End If

Set wbkAll = Workbooks("ALLDATA.xlsm")
If wbkAll Is Nothing Then
  MsgBox "Please open Workbook 'ALLDATA.xlsm' and start the macro again", vbInformation, "Sampler workbook not open"
  GoTo leave_here
End If
Set wksDaily = wbkAll.Worksheets("DailyData")
If wksDaily Is Nothing Then
  MsgBox "No sheet 'DailyData' found", vbInformation, "'DailyData' not found"
  GoTo leave_here
End If
On Error GoTo 0
'/// end of amendment

With wksData
  If wksDaily.UsedRange.Rows.Count = 1 Then
    wksDaily.Range("A1").Resize(1, clngNumCols).Value = .Range("A1").Resize(1, clngNumCols).Value
    '/// giving a startrow for copying
    lngStart = 2
  Else
    On Error Resume Next
    '/// corrected Range to Cells
    Set rngFound = .Range("A:A").Find(wksDaily.Cells(Rows.Count, "A").End(xlUp).Value)
    If rngFound Is Nothing Then
      MsgBox "Could not find  '" & wksDaily.Cells(Rows.Count, "A").End(xlUp).Value & "'", vbInformation, "No match found"
      GoTo leave_here
    Else
      lngStart = rngFound.Row + 1
    End If
  End If
  
  For lngCounter = lngStart To .Range("A" & Rows.Count).End(xlUp).Row
    If UCase(.Range("H" & lngCounter)) = "X" Then
      wksDaily.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, clngNumCols).Value = .Range("A" & lngCounter).Resize(1, clngNumCols).Value
    End If
  Next lngCounter

End With

Application.Goto wksDaily.Range("A" & Rows.Count).End(xlUp)

leave_here:
Set rngFound = Nothing
Set wksDaily = Nothing
Set wbkAll = Nothing
Set wksData = Nothing
Set wbkData = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
Could you please explain the character "X" in Column H? Is it possible that there is an alteration in the rows after data has been copied?

HTH,
Holger
 
Upvote 0
HaHoBe said:
Hi Jirka,

there were obviously a couple of errors in the first code supplied. Both workbooks need to be opened before the macro is run:
VBA Code: 
Sub MrE1218377_2()
'https://www.mrexcel.com/board/threads/copy-and-paste-to-another-workbook-without-overwrite-data.1218377/
Dim lngStart        As Long
Dim lngCounter      As Long
Dim wbkData         As Workbook
Dim wksData         As Worksheet
Dim wbkAll          As Workbook
Dim wksDaily        As Worksheet
Dim rngFound        As Range

Const clngNumCols As Long = 7

Application.ScreenUpdating = False
Application.EnableEvents = False

'/// code amended for the check of the proper sheets to be referenced
On Error Resume Next
Set wbkData = Workbooks("Data.xlsx")
If wbkData Is Nothing Then
  MsgBox "Please open Workbook 'Data.xlsx' and start the macro again", vbInformation, "Data workbook not open"
  GoTo leave_here
End If
Set wksData = wbkData.Worksheets("sheet1")
If wksData Is Nothing Then
  MsgBox "No sheet 'sheet1' found", vbInformation, "Data sheet not found"
  GoTo leave_here
End If

Set wbkAll = Workbooks("ALLDATA.xlsm")
If wbkAll Is Nothing Then
  MsgBox "Please open Workbook 'ALLDATA.xlsm' and start the macro again", vbInformation, "Sampler workbook not open"
  GoTo leave_here
End If
Set wksDaily = wbkAll.Worksheets("DailyData")
If wksDaily Is Nothing Then
  MsgBox "No sheet 'DailyData' found", vbInformation, "'DailyData' not found"
  GoTo leave_here
End If
On Error GoTo 0
'/// end of amendment

With wksData
  If wksDaily.UsedRange.Rows.Count = 1 Then
    wksDaily.Range("A1").Resize(1, clngNumCols).Value = .Range("A1").Resize(1, clngNumCols).Value
    '/// giving a startrow for copying
    lngStart = 2
  Else
    On Error Resume Next
    '/// corrected Range to Cells
    Set rngFound = .Range("A:A").Find(wksDaily.Cells(Rows.Count, "A").End(xlUp).Value)
    If rngFound Is Nothing Then
      MsgBox "Could not find  '" & wksDaily.Cells(Rows.Count, "A").End(xlUp).Value & "'", vbInformation, "No match found"
      GoTo leave_here
    Else
      lngStart = rngFound.Row + 1
    End If
  End If
 
  For lngCounter = lngStart To .Range("A" & Rows.Count).End(xlUp).Row
    If UCase(.Range("H" & lngCounter)) = "X" Then
      wksDaily.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, clngNumCols).Value = .Range("A" & lngCounter).Resize(1, clngNumCols).Value
    End If
  Next lngCounter

End With

Application.Goto wksDaily.Range("A" & Rows.Count).End(xlUp)

leave_here:
Set rngFound = Nothing
Set wksDaily = Nothing
Set wbkAll = Nothing
Set wksData = Nothing
Set wbkData = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
Could you please explain the character "X" in Column H? Is it possible that there is an alteration in the rows after data has been copied?

HTH,
Holger
Click to expand...
Good morning Holger,

The X thing can be omitted, I will finally remove it from column H. Therefore, if you want, you can erase the code regarding this issue and just copy the range up to column G please.

Of course I will try today the code you have just send with the X too, and I will give you feedback later on.

Thanks for your help!!
 
Upvote 0
Flashbond said:
My code won't work unless you have 1 record in Sheet1. Also try to cahnge this line
VBA Code: 
lValue = Cells(lRow1, 1).Value
To this
VBA Code: 
lValue = Sheets("Sheet1")Cells(lRow1, 1).Value
Click to expand...
Hi flashbond,

Thanks for your reply, I will try it and I will text you later on!

Thanks for your help too!
 
Upvote 0
Hi Jirka,

omitting the check means that all new data is to be copied. So there is no more need for a loop, a range is used to copy data over. Code looks like this:
VBA Code: 
Sub MrE1218377_3()
'https://www.mrexcel.com/board/threads/copy-and-paste-to-another-workbook-without-overwrite-data.1218377/
'/// alteration from loop to check Column H to building a range and copy the range
Dim lngStart        As Long
Dim lngCounter      As Long
Dim wbkData         As Workbook
Dim wksData         As Worksheet
Dim wbkAll          As Workbook
Dim wksDaily        As Worksheet
Dim rngFound        As Range
Dim rngCopy         As Range

Const clngNumCols As Long = 7

Application.ScreenUpdating = False
Application.EnableEvents = False

'/// code amended for the check of the proper sheets to be referenced
On Error Resume Next
Set wbkData = Workbooks("Data.xlsx")
If wbkData Is Nothing Then
  MsgBox "Please open Workbook 'Data.xlsx' and start the macro again", vbInformation, "Data workbook not open"
  GoTo leave_here
End If
Set wksData = wbkData.Worksheets("sheet1")
If wksData Is Nothing Then
  MsgBox "No sheet 'sheet1' found", vbInformation, "Data sheet not found"
  GoTo leave_here
End If

Set wbkAll = Workbooks("ALLDATA.xlsm")
If wbkAll Is Nothing Then
  MsgBox "Please open Workbook 'ALLDATA.xlsm' and start the macro again", vbInformation, "Sampler workbook not open"
  GoTo leave_here
End If
Set wksDaily = wbkAll.Worksheets("DailyData")
If wksDaily Is Nothing Then
  MsgBox "No sheet 'DailyData' found", vbInformation, "'DailyData' not found"
  GoTo leave_here
End If
On Error GoTo 0
'/// end of amendment

With wksData
  If wksDaily.UsedRange.Rows.Count = 1 Then
    wksDaily.Range("A1").Resize(1, clngNumCols).Value = .Range("A1").Resize(1, clngNumCols).Value
    '/// giving a startrow for copying
    lngStart = 2
  Else
    On Error Resume Next
    '/// corrected Range to Cells
    Set rngFound = .Range("A:A").Find(wksDaily.Cells(Rows.Count, "A").End(xlUp).Value)
    If rngFound Is Nothing Then
      MsgBox "Could not find  '" & wksDaily.Cells(Rows.Count, "A").End(xlUp).Value & "'", vbInformation, "No match found"
      GoTo leave_here
    Else
      lngStart = rngFound.Row + 1
    End If
  End If
  
  Set rngFound = .Range("A" & Rows.Count).End(xlUp)
  If rngFound.Row >= lngStart Then
    Set rngCopy = .Range(.Range("A" & lngStart), .Range("A" & Rows.Count).End(xlUp)).Resize(, clngNumCols)
    wksDaily.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(rngCopy.Rows.Count, clngNumCols).Value = rngCopy.Value
  Else
    MsgBox "No new data found.", , "Nothing to do here"
  End If
End With

Application.Goto wksDaily.Range("A" & Rows.Count).End(xlUp)

leave_here:
Set rngCopy = Nothing
Set rngFound = Nothing
Set wksDaily = Nothing
Set wbkAll = Nothing
Set wksData = Nothing
Set wbkData = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
Ciao,
Holger
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

J
  • Question Question
How to speed up the for - next statement using always the last 200 rows that contains text of a column
2
Replies
11
Views
1K
Micron
M
C
  • Solved
Copy paste columns based on matching header into another workbook
Replies
5
Views
325
mumps
mumps
O
  • Question Question
User-defined type not defined - vba/excel error
Replies
4
Views
296
RoryA
RoryA
V
  • Solved
Need VBA to split data into multiple sheets paste formulas, formatting AND data validation
Replies
2
Views
123
vanessavalentino83
V
M
  • Solved
Insert new row with incremental formula
Replies
8
Views
711
Sheik
S

Forum statistics

Threads
1,224,823
Messages
6,181,175
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top