• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Compare data from two workbooks and copy data which doesn't exist( criteria Headers of each columns)

Anilp29

New Member
Hello everyone,

I am new to VBA. I need help to sort this.

I have a data of workbook 1 which is updated every 4 hours. I have workbook 2 which is Master file. Workbook 1 has like 25 columns with some headers. Workbook 2(Master file) has only 8 columns with same headers as workbook 1. for example: workbook 1 has headers: A,B,C,D,E,G,H,.......Y and Workbook 2 has headers B,F,I,W,C,V,A,K.

headers are present in row 1. I want a VBA code in Master file (Wb2) which compares column headers and updates data row wise.

If for the first time data from wb1 is 10 rows it copies according to the headers in Master file and second time data in wb1 is 20 rows in which 8 rows are are same and already copied. VBA should copy remaining 12 rows.

Thank you.
#
It would be great help if some can help.
 
See next code.
To fired from workbook2 from sheet where data must be pasted
For more details attach Excel samples
Code:
Option Explicit

Sub CopyData()
Dim OrgWs As Worksheet
Set OrgWs = Workbooks("Workbook1.xlsx").Sheets("Sheet1")
Dim MasterDic   As Object
Set MasterDic = CreateObject("Scripting.Dictionary")
Dim HdDic   As Object
Set HdDic = CreateObject("Scripting.Dictionary")
Dim WkRg  As Range, Rg As Range
Dim D, Val, F, K
Dim I  As Integer, J As Integer, LR  As Integer

    Set WkRg = Cells(1, 1).CurrentRegion
    D = Intersect(WkRg, WkRg.Offset(1, 0))
    For I = LBound(D, 1) To UBound(D, 1)
        Val = ""
        For J = LBound(D, 2) To UBound(D, 2)
            Val = Val & "/" & D(I, J)
        Next J
        Val = Mid(Val, 2)
        MasterDic(Val) = Empty
    Next I
    For Each Rg In WkRg.Rows(1).Cells
        Set F = OrgWs.Rows(1).Find(Rg.Value, LookIn:=xlValues, Lookat:=xlWhole)
        If (Not F Is Nothing) Then HdDic(Rg.Value) = F.Column
    Next Rg
    With OrgWs
        For I = 2 To .Cells(Rows.Count, 1).End(3).Row
            LR = Cells(Rows.Count, 1).End(3).Row
            Val = ""
            For Each K In HdDic.keys
                Val = Val & "/" & .Cells(I, HdDic(K))
            Next K
            Val = Mid(Val, 2)
            If Not (MasterDic.exists(Val)) Then
                J = 1
                For Each K In HdDic.keys
                    .Cells(I, HdDic(K)).Copy Cells(LR + 1, J): J = J + 1
                Next K
            End If
        Next I
    End With
    MsgBox ("Job Done")
End Sub
 
Hello, Thank you for the code. It is copying according to headers but If I copy some 100 data from Wb1 to Master file first time and run the code again it is just pasting same 100 data below, so total 200.

The code should compare data and paste only data which isnt present in Master File. If data is same in the above case it should be only 100.
 
Last edited by a moderator:
"If I copy some 100 data from Wb1 to Master file first time and run the code again"
The macro is checking according to headers in Workbook2 if data exist: Copy/paste only new records
Can you send sample Excel samples showing the isse
 
Hello,I have attached two workbooks wb1,wb2 and masterfile. I will run the macro from masterfile. first wb1 data will be copied and next wb2 data. both wb1 and wb2 have some similar data, so duplicate data should be compared and removed. Wb1 will be first data set and after 4 hours wb2 will be copied to masterfile. so total data should be 13.
 

Attachments

  • masterfile.xlsx
    7.9 KB · Views: 6
  • Workbook1.xlsx
    8.6 KB · Views: 6
  • Workbook2.xlsx
    8.9 KB · Views: 5
I notice that the files you attach are nearly 5 years old; are we doing your assignment/homework for you?
Try this:
Code:
With ThisWorkbook.Sheets("Tabelle1") 'the destination sheet in masterfile
  Set rngHeaders = .Range(.Cells(1), .Cells(1).End(xlToRight))
  Set rngDestn = .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(, rngHeaders.Columns.Count)
  rngHeaders.Copy rngDestn
  Workbooks("Workbook1.xlsx").Sheets(1).Cells(1).CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngDestn, Unique:=False
  rngDestn.Delete Shift:=xlUp
  x = Evaluate("column(" & rngHeaders.Address & ")")
  .Cells(1).CurrentRegion.RemoveDuplicates Columns:=Evaluate(x), Header:=xlYes
End With
End Sub
Note the reference in the code to Workbook1; I'm assuming that this name remains constant, and the workbook content changes. There's also an assumption that the source data is on first (or only) sheet of th Workbook1.
To test this with your attached files, place this code in a standard code module of masterfile and run the code once (no harm if you run it more than once), then change Workbook1 in the code to Workbook2 and run again.
All workbooks should be open before running this code.
Headers must exist in the masterfile sheet before you start.

I've put the code in the attachment.
 

Attachments

  • Chandoo43906masterfile.xlsm
    16.2 KB · Views: 6
Thank you for quick response.

I am getting error on this line
Workbooks("Workbook1.xlsx").Sheets(1).Cells(1).CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngDestn, Unique:=False

"Extract Range missing or invalid field name" 1004
 
Last edited:
Extract Range missing
When you get that error, click the Debug button and in the Immediate Pane (Ctrl+G in the visual basic editor if you can't see it) enter:
Application.Goto rngDestn
and press Enter.
What happens (is selected) on the masterfile sheet?


or invalid field name
The headers in the destination sheet (masterfile) need to be EXACTLY the same as the source sheet headers, although you don't need to have all of them.
Also the code assumes that headers in the source and destination sheets are on row 1.


And to test it's not something entirely different, test the code on the files you attached earlier here.
 
Last edited:
I have noticed that the remove duplicates line is not behaving; this part of it:
Columns:=Evaluate(x)
for now, needs to be hard coded with:
Columns:=Array(1, 2, 3, 4, 5, 6)
while I find a workaround to deal with any number of columns on the destination sheet.
If you have 9 columns on the destination sheet (the sheet in the masterfile) that portion of the code should read:
Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
 
Last edited:
When you get that error, click the Debug button and in the Immediate Pane (Ctrl+G in the visual basic editor if you can't see it) enter:
Application.Goto rngDestn
and press Enter.
What happens (is selected) on the masterfile sheet?



The headers in the destination sheet (masterfile) need to be EXACTLY the same as the source sheet headers, although you don't need to have all of them.
Also the code assumes that headers in the source and destination sheets are on row 1.


And to test it's not something entirely different, test the code on the files you attached earlier here.
Headers Are exactly same as WB1 in Masterfile. They are others headers too in the master file which are not present in the WB1. All headers are present in row 1. It is showing error in the same line:
Workbooks("Workbook1.xlsx").Sheets(1).Cells(1).CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngDestn, Unique:=False

I cannot execute remove duplicates before executing the above line.

Thank you.
 
Again, are we doing your homework for you?
It my task to do. I was asking for help as I am new to vba. learnt many new things by your coding techniques. I also learnt there are many functionalities in VBA, which can be executed.
 
They are others headers too in the master file which are not present in the WB1.
That's the problem.
For advanced filter to work properly, the destination range shouldn't have any headers that don't exist in the source data. Having said that, that range can be part of a larger number of headers if they're all next to each other, then we can define just those columns as the destination range.
Instead of my asking you what's where on your actual sheets, upload realistic versions of the sheets concerned.

It could be that a tweak or two of PCI's code could be made to work, or that Power Query could be pressed into service.
 
Last edited:
I have noticed that the remove duplicates line is not behaving
The attached contains a solution to the remove duplicates problem. It works on your original sample files.
 

Attachments

  • Chandoo43906masterfile.xlsm
    15.5 KB · Views: 7
This code works fine with my files.

Code:
Sub copy()
Dim rng as range
Dim srcBook As Workbook
Set srcBook = Workbooks.Open(path & filename)
Set srcWS = srcBook.Worksheets("sheet1")
Set desWS = ThisWorkbook.Worksheets("Tabelle1")
LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
lCol = desWS.Cells(1, Columns.Count).End(xlToLeft).Column
For Each header In desWS.Range(desWS.Cells(1, 1), desWS.Cells(1, lCol))
Set foundHeader = srcWS.Rows(1).Find(header, LookIn:=xlValues, Lookat:=xlWhole)
If Not foundHeader Is Nothing Then
srcWS.Range(srcWS.Cells(2, foundHeader.Column), srcWS.Cells(LastRow, foundHeader.Column)).Copy desWS.Cells(2, header.Column)
End If
Next header

With desWS
Set Rng = Range("A2", Range("W10000").End(xlDown))
Rng.RemoveDuplicates Columns:=Array(1, 2), header:=xlNo
End With

srcBook.Close SaveChanges:=False
desWS.Range("A:Z").Columns.AutoFit
Set srcBook = Nothing
End Sub
 
Last edited:
This code works fine with my files.
Dangerous because of the red 2 in:
srcWS.Range(srcWS.Cells(2, foundHeader.Column), srcWS.Cells(LastRow, foundHeader.Column)).copy desWS.Cells(2, Header.Column)

If you process Workbook2, then process Workbook1, David goes AWOL. The macro overwrites data from row 2 downwards.
 
Last edited:
Code:
Sub copy()
Dim rng as range
Dim srcBook As Workbook
Set srcBook = Workbooks.Open(path & filename)
Set srcWS = srcBook.Worksheets("sheet1")
Set desWS = ThisWorkbook.Worksheets("Tabelle1")
LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
lCol = desWS.Cells(1, Columns.Count).End(xlToLeft).Column
For Each header In desWS.Range(desWS.Cells(1, 1), desWS.Cells(1, lCol))
Set foundHeader = srcWS.Rows(1).Find(header, LookIn:=xlValues, Lookat:=xlWhole)
If Not foundHeader Is Nothing Then
srcWS.Range(srcWS.Cells(2, foundHeader.Column), srcWS.Cells(LastRow, foundHeader.Column)).Copy desWS.Cells(2, header.Column)
End If
Next header

With desWS
Set Rng = Range("A2", Range("W10000").End(xlDown))
Rng.RemoveDuplicates Columns:=Array(1, 2), header:=xlNo
End With

srcBook.Close SaveChanges:=False
desWS.Range("A:Z").Columns.AutoFit
Set srcBook = Nothing
End Sub

In the above code I want to filter out the status column(I) and then copy. The header is "Current Status" and and status is "Pending", it is column "I". Can anyone help in copying "pending" status from wb1 to masterfile.
 
Back
Top