Copy Rows to destination that exist on the source but not the destination

Hi,

In a previous question, Ejgil Hedegaard provided the attached solution.

The code in the "Destination -Workbook1.xls" file opens another workbook "testdata.xls" sheet1, copies all rows from the source where the date in column A of the source is greater than the latest (max) date in Column A sheet "Raw Data" of the destination (starting with the next blank row of any existing data)

This works quickly and efficiently, however, occasionally lines with a date earlier than the max date (a new date entirely) exist in the source (due to a data anomaly) but not the destination because the code only looks for rows with a date in column A of the source that is later than the max date in the destination.

In the attached example the destination is missing the rows with the date 1/22/2015 and 1/25/2015 in column A. Running the code copies over 1/25/2015 but not 1/22/2015 since the max date in the destination is 1/24/2015.

The solution to this problem would also get 1/22/2015.

The number of lines for any given date will never change so the code does not need to check if there are any more rows for a date that has already been copied over.

Hope I explained this clearly,

Thanks in advance,

swjtx99
Destination-Workbook1.xls
testdata.xls
swjtx99Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

gowflowCommented:
ok here is the new code that will review first if the data in the testdata file has some data not existing in destination then it will import it and after that it will import the remaining new data that is > maxdate

check the attached workbook that have the new macro.

Sub LoadData()
    Dim srcWb As Workbook
    Dim srcWs As Worksheet, destWs As Worksheet
    Dim maxDate As Date
    Dim i As Long, destCurrRow
    Dim rg As Range, sourceMaxRow As Long, sourceMaxColumn As Integer
    Dim cCell As Range
    
   ' Application.ScreenUpdating = False
   With Application
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
   End With
   
   
'    Set DestWb = ActiveWorkbook 'name of the workbook with the macro which is the destination workbook
    Set destWs = ActiveWorkbook.Sheets("Raw Data")
    Set srcWb = Workbooks.Open(ActiveWorkbook.Path & "\testdata.xls")
    'Set srcWb = Workbooks.Open("c:\!data/testdata.xls")
    Set srcWs = srcWb.Sheets("Sheet1")
    
    'Get Max Date
    maxDate = Application.WorksheetFunction.Max(destWs.Range("A:A"))
    
    destCurrRow = destWs.Range("A" & Rows.Count).End(xlUp).Row + 1
    
    sourceMaxRow = srcWs.Range("A1").CurrentRegion.Rows.Count
    sourceMaxColumn = srcWs.Range("A1").CurrentRegion.Columns.Count
    
    '---> Make sure no leftover from last pull
    '     Filter data in source to make sure no data
    '     left that is <MaxDate or else get them in the workbook
    '     before proceeding
    srcWs.Range("A1").AutoFilter field:=1, Criteria1:="<=" & maxDate
    For Each rg In srcWs.Range(Cells(1, 1), Cells(sourceMaxRow, "A")).SpecialCells(xlCellTypeVisible)
        Set cCell = destWs.Range("A:A").Find(what:=rg.Value, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        If cCell Is Nothing Then
            srcWs.Range("A1").AutoFilter field:=1, Criteria1:="=" & rg.Value
            srcWs.UsedRange.SpecialCells(xlCellTypeVisible).Copy destWs.Cells(destCurrRow, 1)
            destWs.Cells(destCurrRow, 1).EntireRow.Delete
            destCurrRow = destWs.Range("A" & Rows.Count).End(xlUp).Row + 1
            srcWs.Range("A1").AutoFilter field:=1, Criteria1:="<=" & maxDate
        End If
    Next rg
    
    '---> Remove Autofilter
    srcWs.Range("A1").AutoFilter
    
    '---> Sort Destination in case some missing dates were addded
    destWs.UsedRange.Sort Key1:="Date", Order1:=xlAscending, Header:=xlYes
    
    Set rg = srcWs.Range(Cells(1, 1), Cells(sourceMaxRow, sourceMaxColumn))
    rg.Sort Key1:="Date", Order1:=xlAscending, Header:=xlYes
    
    i = 1
    Do
        i = i + 1
    Loop Until srcWs.Cells(i, 1) > maxDate Or i > sourceMaxRow
    If i <= sourceMaxRow Then
        srcWs.Range(Cells(i, 1), Cells(sourceMaxRow, sourceMaxColumn)).Copy
        ThisWorkbook.Activate
        destWs.Select
        destWs.Cells(destCurrRow, 1).Select
        destWs.Paste
        Application.CutCopyMode = False
    End If
'    For i = 2 To srcWs.Range("A" & Rows.Count).End(xlUp).Row
'        If srcWs.Range("A" & i).Value > maxDate Then
'            srcWs.Range("A" & i).EntireRow.Copy destWs.Range("A" & destCurrRow)
'            destCurrRow = destCurrRow + 1
'        End If
'    Next i
    
    srcWb.Close SaveChanges:=False

    'Workbooks(MainFile).Worksheets("Table").Select
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
   End With
   
    If i < sourceMaxRow Then
        MsgBox "Data was successfully imported!", vbInformation
    Else
        MsgBox "No data to copy"
    End If
End Sub

Open in new window


gowflow
Destination-Workbook1-V01.xls
0
swjtx99Author Commented:
Hi gowflow,

The code worked on the example but when I tried it on the "production" data with a 7500 line destination file and a 45000 line source file, it ran for about 20 minutes before I had to break it. Seems like it's getting hung up on this part:


    '---> Make sure no leftover from last pull
    '     Filter data in source to make sure no data
    '     left that is <MaxDate or else get them in the workbook
    '     before proceeding
    srcWs.Range("A1").AutoFilter field:=1, Criteria1:="<=" & maxDate
    For Each rg In srcWs.Range(Cells(1, 1), Cells(sourceMaxRow, "A")).SpecialCells(xlCellTypeVisible)
        Set cCell = destWs.Range("A:A").Find(what:=rg.Value, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        If cCell Is Nothing Then
            srcWs.Range("A1").AutoFilter field:=1, Criteria1:="=" & rg.Value
            srcWs.UsedRange.SpecialCells(xlCellTypeVisible).Copy destWs.Cells(destCurrRow, 1)
            destWs.Cells(destCurrRow, 1).EntireRow.Delete
            destCurrRow = destWs.Range("A" & Rows.Count).End(xlUp).Row + 1
            srcWs.Range("A1").AutoFilter field:=1, Criteria1:="<=" & maxDate
        End If
    Next rg

The Destination file has 7300 lines with about 40-50 for each workday starting 1 Jan 2015 and the destination file has about 45000 lines none older than about 20 workdays.

When I get a chance I'll just let it run as long as it takes to see if it will work but is there a faster way to do this?

Thank you for taking the time to help.

swjtx99
0
gowflowCommented:
pls post both so I can test.
gowflow
0
The Ultimate Tool Kit for Technolgy Solution Provi

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy for valuable how-to assets including sample agreements, checklists, flowcharts, and more!

swjtx99Author Commented:
Hi gowflow,

Here are the same workbooks with more rows of data so you can see how the code performs with a data set this large.

Thanks again for your help.

swjtx99
Copy-of-Destination-Workbook1-V01.xls
testdata.xls
0
gowflowCommented:
ok will work on this asasp.
gowflow
0
swjtx99Author Commented:
Hi,

Any updates?
0
gowflowCommented:
sorry was caught with other issue and this one slipped me completely. Will attend sorry for delay.
gowflow
0
gowflowCommented:
Extreemly sorry for the delay in handling this. Here is the new code pls check it out.

Sub LoadData()
    Dim srcWb As Workbook
    Dim srcWs As Worksheet, destWs As Worksheet
    Dim maxDate As Date
    Dim i As Long, destCurrRow
    Dim rg As Range, sourceMaxRow As Long, sourceMaxColumn As Integer
    Dim cCell As Range, UniqueDates As Range
    
   With Application
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
   End With
   
   
'    Set DestWb = ActiveWorkbook 'name of the workbook with the macro which is the destination workbook
    Set destWs = ActiveWorkbook.Sheets("Raw Data")
    Set srcWb = Workbooks.Open(ActiveWorkbook.Path & "\testdata.xls")
    'Set srcWb = Workbooks.Open("c:\!data/testdata.xls")
    Set srcWs = srcWb.Sheets("Sheet1")
    
    'Get Max Date
    maxDate = Application.WorksheetFunction.Max(destWs.Range("A:A"))
    
    destCurrRow = destWs.Range("A" & Rows.Count).End(xlUp).Row + 1
    
    sourceMaxRow = srcWs.Range("A1").CurrentRegion.Rows.Count
    sourceMaxColumn = srcWs.Range("A1").CurrentRegion.Columns.Count
    
    '---> Make sure no leftover from last pull
    '     Filter data in source to make sure no data
    '     left that is <MaxDate or else get them in the workbook
    '     before proceeding

    '---> New Routine
    '---> Take unique values of Dates in Col A put in Col ZZ
    srcWs.Range("A1").AutoFilter field:=1, Criteria1:="<=" & maxDate
    srcWs.Range("A2:A" & sourceMaxRow).SpecialCells(xlCellTypeVisible).Copy srcWs.Range("IV1")
    srcWs.Range("IV:IV").RemoveDuplicates Columns:=1, Header:=xlNo
    Set UniqueDates = srcWs.Range(srcWs.Range("IV1"), srcWs.Cells(srcWs.Rows.Count, "IV").End(xlUp)).SpecialCells(xlCellTypeConstants)
    
    
    '---> OLD Routine
    For Each rg In UniqueDates
        Set cCell = destWs.Range("A:A").Find(what:=rg.Value, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        If cCell Is Nothing Then
            srcWs.Range("A1").AutoFilter field:=1, Criteria1:="=" & rg.Value
            srcWs.UsedRange.SpecialCells(xlCellTypeVisible).Copy destWs.Cells(destCurrRow, 1)
            destWs.Cells(destCurrRow, 1).EntireRow.Delete
            destCurrRow = destWs.Range("A" & Rows.Count).End(xlUp).Row + 1
            srcWs.Range("A1").AutoFilter field:=1, Criteria1:="<=" & maxDate
        End If
    Next rg
    
    '---> Remove Autofilter
    srcWs.Range("A1").AutoFilter
    
    '---> Sort Destination in case some missing dates were addded
    destWs.UsedRange.Sort Key1:="Date", Order1:=xlAscending, Header:=xlYes
    
    Set rg = srcWs.Range(Cells(1, 1), Cells(sourceMaxRow, sourceMaxColumn))
    rg.Sort Key1:="Date", Order1:=xlAscending, Header:=xlYes
    
    i = 1
    Do
        i = i + 1
    Loop Until srcWs.Cells(i, 1) > maxDate Or i > sourceMaxRow
    If i <= sourceMaxRow Then
        srcWs.Range(Cells(i, 1), Cells(sourceMaxRow, sourceMaxColumn)).Copy
        ThisWorkbook.Activate
        destWs.Select
        destWs.Cells(destCurrRow, 1).Select
        destWs.Paste
        Application.CutCopyMode = False
    End If
    
    srcWb.Close SaveChanges:=False

    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
   End With
   
    If i < sourceMaxRow Then
        MsgBox "Data was successfully imported!", vbInformation
    Else
        MsgBox "No data to copy"
    End If
End Sub

Open in new window


Let me know
gowflow
Destination-Workbook1-V02.xlsm
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
swjtx99Author Commented:
Hi gowflow,

Works very very well. Thanks a million.

Only issue is the message box. If the process only copies data < max date, the message says "no data imported".

If it copies data with a date that is > max date, it says "Data imported successfully".

I might be able to fix this but haven't found it yet.

Thanks again,

swjtx99
0
gowflowCommented:
ok here it is

I changed the last routine to read as follows adding 2 more variables to spot at different times what is happening. You can see the new workbook for complete code.

'---> Advise user
    If bNewDate And sMissed <> "" Then
        MsgBox "New Data was successfully imported, and also following missed dates were included " & sMissed, vbInformation
    ElseIf Not bNewDate And sMissed <> "" Then
        MsgBox "Following missed dates were included successfully: " & sMissed
    ElseIf bNewDate And sMissed = "" Then
        MsgBox "New Data successfully Imported."
    Else
        MsgBox "No data was imported."
    End If

Open in new window


gowflow
Destination-Workbook1-V03.xlsm
0
swjtx99Author Commented:
hi goflow,

Thanks. I had worked out a solution but yours is much better.

I am having one issue. On closing the srcWB, the computer hangs and stepping through it manually shows the issue is I'm now getting a "The picture is too large and will be truncated" error when closing the srcWB. Even when I click Ok to the error message (it comes up twice), the srcWB will not close and I have to kill the process. Obviously I am not dealing with a picture so assume it's some kind of memory error? Any ideas?

Thanks,

swjtx99
0
swjtx99Author Commented:
Some google searching leads me to the conclusion that it is a MS Clip Organizer issue. I have tried inserting CutCopyMode = False prior to closing the WB but no luck. Any way to flush it before closing the srcWB?
0
gowflowCommented:
nope this is not the issue. Do you use more macro than the one posted or only this one ?
gowflow
0
swjtx99Author Commented:
Hi goflow.

There are a few macros in the WB but none are doing much of significance.

Update: on reboot, the issue is no longer there. Strange. Maybe there was just a glitch with Excel?

Hopefully that was it and if so, sorry for the false alarm.

Thanks,

swjtx99
0
gowflowCommented:
Well better be safe this should do it.
gowflow
Destination-Workbook1-V04.xlsm
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.