Copy data from one workbook to another

[Exceldeveloper123]

Hi all I have created a macro as follows, when I opened the document it will create a new work book. When ever user changed data I would like to copy entire row data to another excel sheet in the new work sheet. Attached the excel with macro code can some one help me

[af25]

So are you creating a new workbook every time you open the workbook? and then wanting to copy any data from the first workbook to the second?
Could you explain this further? If necessary make an example workbook showing before and after with what you hope to achieve.

[Exceldeveloper123]

So are you creating a new workbook every time you open the workbook? and then wanting to copy any data from the first workbook to the second?
Could you explain this further? If necessary make an example workbook showing before and after with what you hope to achieve.

Then when I start editing any sheet I would like to copy the entire row where I am making changes example if I am having 2 rows in original document, I started editing 2 row then that 2 row only should be in new worksheet. This should work no of sheets I have in workbook. Check my attachments

[Exceldeveloper123]

Any help please ?

[davesexcel]

It looks like you never Dim'd the workbooks.
See if this works for you.
Public Dim the Workbooks at the Start of the Workbook Module.
It should pass down to the Sheet_Change code.

Public Dwb As Workbook, Swb As Workbook
Private Sub Workbook_Open()
Dim newFileName As String, newFilePath As String
Dim Sws As Worksheet, Dws As Worksheet, ws As Worksheet
Set Swb = ActiveWorkbook
newFilePath = Swb.Path & "\"
.......

[Exceldeveloper123]

It looks like you never Dim'd the workbooks.
See if this works for you.
Public Dim the Workbooks at the Start of the Workbook Module.
It should pass down to the Sheet_Change code.

Public Dwb As Workbook, Swb As Workbook
Private Sub Workbook_Open()
Dim newFileName As String, newFilePath As String
Dim Sws As Worksheet, Dws As Worksheet, ws As Worksheet
Set Swb = ActiveWorkbook
newFilePath = Swb.Path & "\"
.......

Thanks daves but still I am having issue with my code not getting any error but not working as required

Public Dwb As Workbook, Swb As Workbook
Private Sub Workbook_Open()
Dim newFileName As String, newFilePath As String
Dim Sws As Worksheet, Dws As Worksheet, ws As Worksheet
Set Swb = ActiveWorkbook
newFilePath = Swb.Path & "\"
newFileName = Day(Date) & "-" & Format(Date, "mmm") & "  " & Format(Now, "hh-mm-ss")
Swb.Sheets.Copy
Set Dwb = ActiveWorkbook
Dwb.SaveAs newFilePath & newFileName
For Each Sws In Swb.Worksheets
    For Each Dws In Dwb.Worksheets
        If Dws.Name = Sws.Name Then
            Dws.Cells.Clear
            Sws.Rows(1).Copy Dws.Range("A1")
            Sws.Rows(2).Copy Dws.Range("A2")
            Exit For
        End If
    Next Dws
Next Sws
Swb.Activate
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Dim Sws As Worksheet
Dim ws As Worksheet
Dim lastRow As Long, Scol As Long, lastColumn As Long
Dim Drng As Range, DO1rng As Range, cell As Range

Set Sws = Swb.ActiveSheet
Scol = Target.Column
For Each ws In Dwb.Worksheets
    If ws.Name = Sws.Name Then
        lastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
        lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
        
        If Target.Column = 2 Then
            Set Drng = ws.Range(ws.Cells(1, Scol), ws.Cells(lastRow, Scol))
            Set DO1rng = ws.Range(ws.Cells(1, Scol + 1), ws.Cells(lastRow, Scol + 1))
            
            'count the number of cells with in a range
            If WorksheetFunction.CountIf(Drng, Target) = 0 And WorksheetFunction.CountIf(DO1rng, Target.Offset(0, 1)) = 0 Then
                Target.EntireRow.Copy ws.Range("A" & Rows.Count).End(3)(2)
            Else
                Set Drng = ws.Range(ws.Cells(1, Scol + 1), ws.Cells(lastRow, Scol + 1)) 'Returns a Range object that represents a cell or a range of cells
                Set cell = Drng.Find(Target.Offset(0, 1)) 'Finds specific information in a range
                ws.Cells(cell.Row, Scol) = Target
            End If
        ElseIf Target.Column > 1 Then
            lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
            Set Drng = ws.Range(ws.Cells(1, Scol - 1), ws.Cells(lastRow, Scol - 1))
            If WorksheetFunction.CountIf(Drng, Target.Offset(0, -1)) = 0 Then
                Target.EntireRow.Copy ws.Range("A" & Rows.Count).End(3)(2)
            Else
                Set cell = Drng.Find(Target.Offset(0, -1))
                ws.Cells(cell.Row, Scol) = Target
            End If
        End If
    End If
Next ws
Swb.Save
Dwb.Save
End Sub

My new code after your suggestion

[davesexcel]

What's not working?

[Exceldeveloper123]

When I am having the same names and when editing the data instead of pasting it in original cell it was placing in another cell

[davesexcel]

I'm having problems passing down the workbook name to the Sheet_Change event. Possibly putting the sheet name in a cell, for this example I used E1 to put the new sheet name. Then the worksheet_Change code will use that value in E1 to determine the workbook name.

So when you open the workbook, it creates a new workbook and puts the new workbook name in E1

Public Dwb As Workbook, Swb As Workbook
Private Sub Workbook_Open()
    Dim newFileName As String, newFilePath As String
    Dim Sws As Worksheet, Dws As Worksheet, ws As Worksheet
    Set Swb = ActiveWorkbook
    newFilePath = Swb.Path & "\"
    newFileName = Day(Date) & "-" & Format(Date, "mmm") & "  " & Format(Now, "hh-mm-ss")
    Application.EnableEvents = 0

    Swb.Sheets(1).[E1] = newFileName
    Application.EnableEvents = 1

    Swb.Sheets.Copy
    Set Dwb = ActiveWorkbook
    Dwb.SaveAs newFilePath & newFileName
    For Each Sws In Swb.Worksheets
        For Each Dws In Dwb.Worksheets
            If Dws.Name = Sws.Name Then
                Dws.Cells.Clear
                Sws.Rows(1).Copy Dws.Range("A1")
                Sws.Rows(2).Copy Dws.Range("A2")
                Exit For
            End If
        Next Dws
    Next Sws
    Swb.Activate

End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    Dim Sws As Worksheet, r, c, nm As String
    Set Swb = ActiveWorkbook
    Dim ws As Worksheet
    Dim lastRow As Long, Scol As Long, lastColumn As Long
    Dim Drng As Range, DO1rng As Range, cell As Range
    Set ws = ActiveSheet
    nm = Swb.Sheets(1).[E1].Value & ".xlsx"
    Set Dwb = Workbooks(nm)

    Set ws = Dwb.Sheets(1)
    r = Target.Row
    c = Target.Column
    With ws
        .Cells(r, c) = Target
    End With
    Swb.Save
    Dwb.Save
End Sub

[Exceldeveloper123]

I didn't get but here is the excel which is working fine except the issue explained. So can you please look in to it.

[davesexcel]

Don't quote whole posts -- it's just clutter. If you are responding to a post out of sequence, limit quoted content to a few relevant lines that makes clear to whom and what you are responding.

[Exceldeveloper123]

Sure I will keep it in mind from next time

[davesexcel]

Select the code and hit the Keys Ctrl & F
Find
activecell
replace
target

See if that makes a difference.

[davesexcel]

Okay, I think I understand.
When you enter new data, you want the row to copy and paste to a new row in the new workbook.
If you were to edit existing data, you want the edit to show in the new workbook.
Is all this really necessary?
Why wouldn't you just add a date column to the existing workbook?

[Exceldeveloper123]

Yes. I can not add that as the data will be generated from a program where it will have the fixed columns

[davesexcel]

You can edit your previous posts and delete the quoted text.

[davesexcel]

I am not sure what you are trying to do.
You create a new workbook, then clear all the information.
Then you want to edit the information and have the new workbook adjust to the edited information. Trouble is, you cleared all that data, so there is nothing to edit.

Could you not just save the new data workbook as today's date, then work with the data from there?

[Exceldeveloper123]

Ok here is what I am doing. The one I attached is the original copy
1) When I open that I will create a new work book with empty sheets as per the original document with out data (Which is working fine)
2) Assume I have 50 rows in sheet1 of original document, and I am making some changes(on 20th row) then that row data with changes should be presented in the same sheet which I created on opening the document(Which is working fine). If data is there it will get placed to the next available row.
3) When I edit the same row(20) again that should replace the existing row on the new workbook which is working fine

The only issue is when I am having same data in different columns my macro is failing to replace the exact data.

Have u downloaded the file and tested ?

[Exceldeveloper123]

The piece of code where I got problem is below in else block

 If WorksheetFunction.CountIf(Drng, Target.Offset(0, -1)) = 0 Then
                Target.EntireRow.Copy ws.Range("A" & Rows.Count).End(3)(2)
            Else
                Set cell = Drng.Find(Target.Offset(0, -1))
                ws.Cells(cell.Row, Scol) = Target
            End If

What I will have common is ID for every sheet, so if data exists in the sheet of newly created workbook with the same Id I need to replace that else I need to copy it to the last available empty row

[Exceldeveloper123]

I am attaching the word document with the flow how my macro should work and how it is working so please let me if you have any questions

[davesexcel]

First find the code that is going to work for you.

1. Instead of Resaving the workbook, open a workbook that has no data in it.(this way you can set a variable for the workbook)
2. There is a seperate code to Add data, and a seperate code to edit data.
3. Once you have finished with the workbook, then save it.

OPen the workbook and the code to open the NewWB is started.

Sub Open_NewBook()
    Dim MyDir As String
    Dim Mywb As String
    Dim MyFile As String
    Dim WB As Workbook
    Dim ThisBk As Workbook
    Set ThisBk = ThisWorkbook
    MyDir = "C:\Users\davesexcel\Downloads\MyFolder\"
    Mywb = "NewBook.xlsx "
    MyFile = MyDir & Mywb
    Workbooks.Open Filename:=MyFile
    Set WB = ActiveWorkbook
    ThisBk.Activate
End Sub

Code to add new data to the NewWB

Sub MoveData()
    Dim MyBk As Workbook
    Dim MySh As Worksheet
    Dim sh As Worksheet, shNm As String
    Dim r As Integer
    Dim c As Integer
    Set MyBk = Workbooks("NewBook.xlsx")
    Set sh = ActiveSheet
    shNm = sh.Name
    Set MySh = MyBk.Worksheets(shNm)
    r = ActiveCell.Row
    c = ActiveCell.Column
    MySh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Range("A1:D1").Value = Range(Cells(r, 1), Cells(r, 4)).Value

End Sub

Code to Edit the Existing Data in NewWB

Sub EditData()
    Dim MyBk As Workbook
    Dim MySh As Worksheet
    Dim sh As Worksheet, shNm As String, x As Range
    Dim r As Integer
    Dim c As Integer
    Set MyBk = Workbooks("NewBook.xlsx")
    Set sh = ActiveSheet
    shNm = sh.Name
    Set MySh = MyBk.Worksheets(shNm)
    r = ActiveCell.Row
    c = ActiveCell.Column
    Set x = MySh.Columns(1).Find(sh.Cells(ActiveCell.Row, 1), LookIn:=xlValues)
    If Not x Is Nothing Then
        MySh.Cells(x.Row, "A").Range("A1:D1").Value = Range(Cells(r, 1), Cells(r, 4)).Value
    End If
End Sub

Then the code to Save the newWB after you are finished with it.

Sub SaveBk()
    Dim MyDir As String
    Dim Mywb As String
    Dim MyFile As String
    Dim WB As Workbook
    Dim ThisBk As Workbook
    Set ThisBk = ThisWorkbook
    MyDir = "C:\Users\davesexcel\Downloads\MyFolder\"
    Mywb = Day(Date) & "-" & Format(Date, "mmm") & "  " & Format(Now, "hh-mm-ss") & ".xlsx"
    MyFile = MyDir & Mywb
    Set WB = Workbooks("NewBook.xlsx")
WB.SaveAs MyFile

End Sub

Once you have all those codes figured out, then you can start working on getting the codes to Activate with the Worksheet_Change Events.
The idea is not to have conflicting codes.

Arrange the two workbooks, side by side, then you can see better what is going on.when you run the codes.

The zipped folder has the .xlsm wb and the .xlsx wb.

[Exceldeveloper123]

Ok instead of hard coding the columns how can I have it dynamic

MySh.Cells(x.Row, "A").Range("A1:D1").Value = Range(Cells(r, 1), Cells(r, 4)).Value

instead of A1:D1 A:End also Cells(r, 4) will copy 4 cells data but here I need to the complete cells data. Columns can vary in the sheets can u hel pme

[davesexcel]

Edit Data Find Last Column

Sub EditData()
    Dim MyBk As Workbook
    Dim MySh As Worksheet
    Dim sh As Worksheet, shNm As String, x As Range
    Dim r As Integer
    Dim c As Integer
    Set MyBk = Workbooks("NewBook.xlsx")
    Set sh = ActiveSheet
    shNm = sh.Name
    Set MySh = MyBk.Worksheets(shNm)
    r = ActiveCell.Row
    c = Cells(1, Columns.Count).End(xlToLeft).Column
    Set x = MySh.Columns(1).Find(sh.Cells(ActiveCell.Row, 1), LookIn:=xlValues)
    If Not x Is Nothing Then
        MySh.Range(MySh.Cells(x.Row, "A"), MySh.Cells(x.Row, c)).Value = Range(Cells(r, 1), Cells(r, c)).Value
    End If
End Sub

[Exceldeveloper123]

The same I need to do for Add also or will it be different

MySh.Range(MySh.Cells(x.Row, "A"), MySh.Cells(x.Row, c)).Value = Range(Cells(r, 1), Cells(r, c)).Value

This is what I tried it is giving an exception

[davesexcel]

Try this,

 Sub MoveData()
    Dim MyBk As Workbook
    Dim MySh As Worksheet
    Dim sh As Worksheet, shNm As String
    Dim r As Integer
    Dim c As Integer
    Set MyBk = Workbooks("NewBook.xlsx")
    Set sh = ActiveSheet
    shNm = sh.Name
    Set MySh = MyBk.Worksheets(shNm)
    r = ActiveCell.Row
    c = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    MySh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Range(MySh.Cells(1, 1), MySh.Cells(1, c)).Value = Range(Cells(r, 1), Cells(r, c)).Value

End Sub

[Exceldeveloper123]

Thanks a ton davesexcel

[Exceldeveloper123]

I need one final help I am attaching an excel I tried by changing the code but it is not inserting at exact row. Sorry for that find my excel which have multiple headers so the newly created sheet will have multiple and this is my code

Dim dataBook As Workbook
Dim NewWorkbook As Workbook
Private Sub Workbook_Open()
Dim i As Integer
Dim newFileName As String, newFilePath As String
Dim dataSheet As Worksheet, newSheet As Worksheet
Set dataBook = ActiveWorkbook
newFilePath = dataBook.Path & "\"
newFileName = Day(Date) & "-" & Format(Date, "mmm") & "  " & Format(Now, "hh-mm-ss AM/PM")
dataBook.Sheets.Copy
Set NewWorkbook = ActiveWorkbook
i = 0
NewWorkbook.SaveAs newFilePath & newFileName
For Each dataSheet In dataBook.Worksheets
    For Each newSheet In NewWorkbook.Worksheets
        If newSheet.Name = dataSheet.Name Then
            If i <> 0 Then
                newSheet.Cells.Clear
                dataSheet.Rows(1).Copy newSheet.Range("A1")
                dataSheet.Rows(1).Copy newSheet.Range("B2")
            End If
            i = 1
            Exit For
        End If
    Next newSheet
Next dataSheet
dataBook.Activate
End Sub

Private Sub Workbook_SheetChange(ByVal o As Object, ByVal Target As Range)
    Dim sh As Worksheet
    Dim MySh As Worksheet
    Dim shNm As String
    Dim r As Integer
    Dim c As Integer
    Set sh = ActiveSheet
    shNm = sh.Name
    Set MySh = NewWorkbook.Worksheets(shNm)
    r = ActiveCell.Row
    c = Cells(1, Columns.Count).End(xlToLeft).Column
    Set x = MySh.Columns(2).Find(sh.Cells(ActiveCell.Row, 2), LookIn:=xlValues)
    If Not x Is Nothing Then
        MySh.Range(MySh.Cells(x.Row, "A"), MySh.Cells(x.Row, c)).Value = Range(Cells(r, 1), Cells(r, c)).Value
    Else
        MySh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Range(MySh.Cells(1, 1), MySh.Cells(1, c)).Value = Range(Cells(r, 1), Cells(r, c)).Value
    End If
    SaveBk
End Sub

Sub SaveBk()
    Dim WB As Workbook
    Dim ThisBk As Workbook
    Set ThisBk = ThisWorkbook
    Set WB = NewWorkbook
ThisBk.Save
WB.Save
End Sub

[Exceldeveloper123]

No dave this is the code it is replacing the 2nd row data

Private Sub Workbook_SheetChange(ByVal o As Object, ByVal Target As Range)
    Dim sh As Worksheet
    Dim MySh As Worksheet
    Dim shNm As String
    Dim r As Integer
    Dim c As Integer
    Set sh = ActiveSheet
    shNm = sh.Name
    Set MySh = NewWorkbook.Worksheets(shNm)
    r = Target.Row
    c = Cells(1, Columns.Count).End(xlToLeft).Column
    Set x = MySh.Columns(2).Find(sh.Cells(Target.Row, 2), LookIn:=xlValues)
    If Not x Is Nothing Then
        MySh.Range(MySh.Cells(x.Row, "A"), MySh.Cells(x.Row, c)).Value = Range(Cells(r, 1), Cells(r, c)).Value
    Else
        MySh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Range(MySh.Cells(1, 1), MySh.Cells(1, c)).Value = Range(Cells(r, 1), Cells(r, c)).Value
    End If
    SaveBk
End Sub

[davesexcel]

It shouldn't make a difference, the code uses dynamic ranges, not static ranges.
if you want to go 1 row down then go row+1 if you want to go 1 row up then row-1
For example

MySh.Cells(x.Row, c)

to make it become 1 row below

MySh.Cells(x.Row+1, c)

[Exceldeveloper123]

Hi that didn't worked too this is what I tried and having an issue inserting data in +1 row after first row

Private Sub Workbook_SheetChange(ByVal o As Object, ByVal Target As Range)
    Dim sh As Worksheet
    Dim MySh As Worksheet
    Dim shNm As String
    Dim r As Integer
    Dim c As Integer
    Set sh = ActiveSheet
    shNm = sh.Name
    Set MySh = NewWorkbook.Worksheets(shNm)
    r = Target.Row
    c = Cells(1, Columns.Count).End(xlToLeft).Column
    Set x = MySh.Columns(2).Find(sh.Cells(Target.Row, 2), LookIn:=xlValues)
    If Not x Is Nothing Then
        MySh.Range(MySh.Cells(x.Row, "A"), MySh.Cells(x.Row, c)).Value = Range(Cells(r, 1), Cells(r, c)).Value
    Else
        MySh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Range(MySh.Cells(2, 1), MySh.Cells(2, c)).Value = Range(Cells(r, 1), Cells(r, c)).Value
    End If
    SaveBk
End Sub

Works fine the only issues is after first row the data is inserting in by giving a line break

macro.png

[davesexcel]

This should work, one thing you were doing was looking for the ID number in the wrong column.

Private Sub Workbook_SheetChange(ByVal o As Object, ByVal Target As Range)
    Dim sh As Worksheet
    Dim MySh As Worksheet
    Dim shNm As String
    Dim r As Integer
    Dim c As Integer
    Set sh = ActiveSheet
    shNm = sh.Name
    Set MySh = NewWorkbook.Worksheets(shNm)
    r = Target.Row
    c = Cells(1, Columns.Count).End(xlToLeft).Column
    Set x = MySh.Columns(1).Find(sh.Cells(Target.Row, 1), LookIn:=xlValues)
    If Not x Is Nothing Then
        MySh.Range(MySh.Cells(x.Row, "A"), MySh.Cells(x.Row, c)).Value = Range(Cells(r, 1), Cells(r, c)).Value
    Else
        MySh.Cells(Rows.Count, "B").End(xlUp).Offset(1, -1).Range(MySh.Cells(1, 1), MySh.Cells(1, c)).Value = Range(Cells(r, 1), Cells(r, c)).Value
    End If
    SaveBk
End Sub