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