PDA

View Full Version : [SOLVED] Copy data from one worksheet to another based on date



oam
08-19-2015, 07:12 PM
I am using Ron De Bruin's macro shown below to copy data from one worksheet to another and it works well until the operator has a problem, runs the macro again, and the data gets copied twice, then I have duplicate data. What I need to know, can the code be adapted or a new macro to only copy today's data and if run again it would not add today's data twice to the other worksheet.

Is this possible? Thank you for your help!




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("Shipping Manifest Database.xlsm") Then
Set DestWB = Workbooks("Shipping Manifest Database.xlsm")
Else
Set DestWB = Workbooks.Open("G:\CSA\Shipping Data\Shipping Manifest Database.xlsm")
End If

'Change the Source Sheet and range
Set SourceRange = ThisWorkbook.Sheets("4 PM").Range("I6:N150")
'Change the sheet name of the database workbook
Set DestSh = DestWB.Worksheets("Shipping 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

mancubus
08-19-2015, 11:12 PM
filter your table so visible rows contain only today's records.

then search below in your favorite search engine:
"excel vba copy autofilter range without header"

oam
08-21-2015, 03:58 PM
At the risk of sounding dense, I don’t understand! I have search on line for “excel vba copy autofilter range without header” and was unable to find something that would do what I needed it to do. I need a macro that would either not copy the data to the database sheet or would over write current data if the date was “today”.


Thank you for your response and please forgive me if I come across as brash.

oam
08-27-2015, 03:59 PM
Anyone out there know how I can modify the above code or add a new code that would either not copy the data to the database sheet or would over write current data if the date was “today”.

Thank you for your help

domfootwear
08-27-2015, 05:54 PM
Please upload your file (Result and Database files)

mperrah
08-27-2015, 10:43 PM
Is there a date in any of the cells in the source that you can run a test before copying?
And compare to a date in the destination cells.
If they match end copying sub and give msgbox to user stating what happened

Your code seems to copy everything. Is there a specific cell column or row that has dates?

mperrah
08-27-2015, 10:54 PM
Something like:


Sub testdate()
Dim s as worksheet
Dim x as integer

Set s as sheets("sourcesheet") ' you fix the name

For x = 1 to s.cells(rows.count, 1).end(xlup).row
If s.cells(x, 1).value = day(now) then ' not tested but close
Msgbox("You are copying today's information")
Exit sub
Else
' code to copy data ...
End if
Next x

End sub

SamT
08-28-2015, 12:57 PM
Try making these changes to your code. (Not tested, and never before tried.)

Dim TestRange As Range

On Error Resume Next
With SourceRange
Set TestRange = DestRange.Offset(-1).Resize(.Rows.Count * -1, .Columns.Count)
Set DestRange = DestRange.Resize(.Rows.Count, .Columns.Count)
End With
If TestRange.Value = SourceRange.Value Then
MsgBox 'mesage to user"
ExitSub
Else
DestRange.Value = SourceRange.Value
End If
On Error GoTo 0

oam
10-16-2015, 07:39 PM
I was able to get Ron's code to work for me.

Thank you all for all your help.