Copy and paste to another workbook without overwrite data

[Jirka79]

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...

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

 

[HaHoBe]

Hi Jirka79,

codeline

    Set rngCopy = .Range(.Range("A" & lngStart), .Range("A" & Rows.Count).End(xlUp)).Resize(, clngNumCols)

should look like

    Set rngCopy = .Range(.Range("A" & lngStart), rngFound).Resize(, clngNumCols)

and use the range object instead of repeating to get the last used cell in Column A. Both codes work as intended.

Ciao,
Holger

 

[Jirka79]

My code won't work unless you have 1 record in Sheet1. Also try to cahnge this line

lValue = Cells(lRow1, 1).Value

To this

lValue = Sheets("Sheet1")Cells(lRow1, 1).Value

Unfortunately didn't work... keeps doing the same thing... However, Holger's solution worked fine!

Thanks anyway for your time and effort helping me!

 

[Jirka79]

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:

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

I still didn't check your last review, but the previous code just worked perfect!!! Thank you so much for your time and effort helping me!

I will now add the easy function to open the Data.xlsx file in the background and it will be done

 

[HaHoBe]

Hi Jirka79,

it's up to you which code you choose as long as the solution is working like you expect it to do. Glad I could be of help and thanks for the feedback.

Holger

 

[Jirka79]

Hi Jirka79,

it's up to you which code you choose as long as the solution is working like you expect it to do. Glad I could be of help and thanks for the feedback.

Holger

Sure thing!!

By the way... just wondering... if the unique value that the operators enter, would be in column G instead to be in the column A, I would just need to change this line of the code and substitute all "A" for "G" in the line of Set rngFound?

    '/// 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

 

[HaHoBe]

Hi Jirka79,

regarding the sniplet you posted that is correct: replace A with G. If you use the version with the loop nothing more needs to be changed whereas the version with copying the range (MrE1218377_3) would need an alteration from

  Set rngFound = .Range("A" & Rows.Count).End(xlUp)
  If rngFound.Row >= lngStart Then
    Set rngCopy = .Range(.Range("A" & lngStart), rngFound).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

to

  Set rngFound = .Range("G" & Rows.Count).End(xlUp)
  If rngFound.Row >= lngStart Then
    Set rngCopy = .Range(.Range("A" & lngStart), rngFound)
    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

Ciao,
Holger