PDA

View Full Version : [SOLVED] Delete Duplicate Data



oam
03-25-2015, 06:48 PM
I am using Ron de Bruin’s code (shown below) to copy data from one workbook to a Database sheet and it works well however, if the code errors out for any reason and you rerun the code, the data is copied twice into the database.

What I would like to know, is there a way to delete the rows of the data that are duplicates or verify the data prior to copying? Excel 2007






Sub Copy_To_Another_Workbook()
Dim SourceRange As Range
Dim DestRange As Range
Dim DestWB As Workbook
Dim DestSh As Worksheet
Dim Lr As Long
Dim rCell As Range
Dim rChange As Range



With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Change the file name (2*) and the path/file name to your file
If bIsBookOpen_RB("QC Manifest Database.xlsm") Then
Set DestWB = Workbooks("QC Manifest Database.xlsm")
Else
Set DestWB = Workbooks.Open("Z:\Excel Files\Test\Manifest Database.xlsm")
End If

'Change the Source Sheet and range
Set SourceRange = ThisWorkbook.Sheets("4 PM").Range("A6:F40")
'Change the sheet name of the database workbook
Set DestSh = DestWB.Worksheets("Data")

Lr = LastRow(DestSh)
Set DestRange = DestSh.Range("A" & Lr + 1)

'We make DestRange the same size as SourceRange and use the Value
'property to give DestRange the same values
With SourceRange
Set DestRange = DestRange.Resize(.Rows.Count, .Columns.Count)
End With
DestRange.Value = SourceRange.Value


' DestWB.Close savechanges:=True

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Function bIsBookOpen_RB(ByRef szBookName As String) As Boolean
' Rob Bovey
On Error Resume Next
bIsBookOpen_RB = Not (Application.Workbooks(szBookName) Is Nothing)
End Function

Yongle
03-27-2015, 07:09 AM
The very handy "Remove Duplicates" found on the Data tab in Excel2007 should sort this for you.

Suggest you test this manually in Excel initially
Select your table of data, and click on Remove Duplicates, accepting all the columns suggested - Excel will then check through all rows and retain the first of any duplicates rows it finds and remove the rest.

If you are happy that it is doing what you want, it is quite easy to slot it into the VBA. Use a macro to record what you do and then replace the recorded range with a dynamic range for verifying - that range will need to be dynamic as it will vary each time. It will probably look something like:


MyRange.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlNo

Yongle
03-29-2015, 12:00 PM
@OAM - did this sort the problem for you?
If it did, please go to top of thread and click on "Thread Tools" and mark the thread as solved

oam
03-30-2015, 05:17 PM
I was unable to get the line of code work with the code above. Any suggestions on how to integrate your line of code into the macro above?

Yongle
03-30-2015, 09:38 PM
Did you manage to record a macro to delete the duplicates as suggested in post#2?
Please post the code that was generated.

It will probably look something like:
MyRange.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlNo
thanks

oam
03-31-2015, 06:45 PM
Yongle,

I have to apologize to you, I asked the wrong question. I should have asked you; how can I get the code to overwrite the data that is dated with the current date in column “A” and add any additional lines of data that may have been added to the table.

Sorry for any confusion that I may have caused.

snb
04-01-2015, 12:51 AM
Copy the new data to the destination sheet.
Removeduplicates in the destination sheet like Yongle suggested.

oam
04-02-2015, 06:46 PM
Thank you all for your help, With your help I got it working.

Thank you again for the help.