VBA Code please
 

Hi 'Experts'

I was given the following code several weeks back and it works fine.
Basicaly once a macro button is selected the code will add all the data on a
worksheet to a 'database',(another worksheet)
Can somebody show me (as I am the novice) how to change this code so that
once the macro button is selected a 'time' check is made so that no data will
be added to the database before - lets say 10pm.
If the user selects this macro and the time IS before 10pm a msg box pops up
advising so, or if after 10pm all the jobs are added.
Hope that souns ok, and hope you can help.
here is the code (donated and tweeked a little)

Sub add_Anydays_jobs()

Dim DataWks As Worksheet
Dim LogWks As Worksheet
Dim FoundACellDiff As Boolean
Dim FoundAGroupMatch As Boolean
Dim RngToCopy As Range
Dim testRng As Range
Dim iRow As Long
Dim FirstRowToCheck As Long
Dim LastRowToCheck As Long
Dim cCol As Long
Dim cRow As Long
Dim DestCell As Range

Set DataWks = Worksheets(ActiveSheet.Name)
Set LogWks = Worksheets("Log")
Set RngToCopy = DataWks.Range("a8:n34")

With LogWks
FirstRowToCheck = 5 'headers?
LastRowToCheck = .Cells(.Rows.Count, "A").End(xlUp).Row
FoundAGroupMatch = False
For iRow = FirstRowToCheck To LastRowToCheck
'topleftcell of possible range to paste
Set testRng = .Cells(iRow, "A")
FoundACellDiff = False
For cRow = 1 To RngToCopy.Rows.Count
For cCol = 1 To RngToCopy.Columns.Count
If CStr(RngToCopy.Cells(cRow, cCol).Value) _
= CStr(testRng.Cells(cRow, cCol).Value) Then
'still the same
'so do nothing
Else
If CStr(RngToCopy.Cells(cRow, 2).Value) < "" Then
FoundACellDiff = True
End If
Exit For
End If
Next cCol
If FoundACellDiff Then
Exit For
End If
Next cRow
If FoundACellDiff = False Then
FoundAGroupMatch = True
Exit For
End If
Next iRow

If FoundAGroupMatch = True Then
MsgBox "This log has already been copied to the database",
vbExclamation
'exit sub '????
Else
'do the copy
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
DestCell.Resize(RngToCopy.Rows.Count, _
RngToCopy.Columns.Count).Value _
= RngToCopy.Value
MsgBox "All Today's Jobs Added Successfully !", vbInformation
End If
End With


End Sub


Many thanks
Anthony

VBA Code please
 

Maybe just add this kind of thing near the top:


If Time < TimeSerial(22, 0, 0) Then
MsgBox "It's too early!"
Exit Sub
End If

Or....

If (Time TimeSerial(4, 0, 0)) _
And (Time < TimeSerial(22, 0, 0)) Then
MsgBox "It's too early!"
Exit Sub
End If

If you want to allow from 10PM to 4AM.



Anthony wrote:

Hi 'Experts'

I was given the following code several weeks back and it works fine.
Basicaly once a macro button is selected the code will add all the data on a
worksheet to a 'database',(another worksheet)
Can somebody show me (as I am the novice) how to change this code so that
once the macro button is selected a 'time' check is made so that no data will
be added to the database before - lets say 10pm.
If the user selects this macro and the time IS before 10pm a msg box pops up
advising so, or if after 10pm all the jobs are added.
Hope that souns ok, and hope you can help.
here is the code (donated and tweeked a little)

Sub add_Anydays_jobs()

Dim DataWks As Worksheet
Dim LogWks As Worksheet
Dim FoundACellDiff As Boolean
Dim FoundAGroupMatch As Boolean
Dim RngToCopy As Range
Dim testRng As Range
Dim iRow As Long
Dim FirstRowToCheck As Long
Dim LastRowToCheck As Long
Dim cCol As Long
Dim cRow As Long
Dim DestCell As Range

Set DataWks = Worksheets(ActiveSheet.Name)
Set LogWks = Worksheets("Log")
Set RngToCopy = DataWks.Range("a8:n34")

With LogWks
FirstRowToCheck = 5 'headers?
LastRowToCheck = .Cells(.Rows.Count, "A").End(xlUp).Row
FoundAGroupMatch = False
For iRow = FirstRowToCheck To LastRowToCheck
'topleftcell of possible range to paste
Set testRng = .Cells(iRow, "A")
FoundACellDiff = False
For cRow = 1 To RngToCopy.Rows.Count
For cCol = 1 To RngToCopy.Columns.Count
If CStr(RngToCopy.Cells(cRow, cCol).Value) _
= CStr(testRng.Cells(cRow, cCol).Value) Then
'still the same
'so do nothing
Else
If CStr(RngToCopy.Cells(cRow, 2).Value) < "" Then
FoundACellDiff = True
End If
Exit For
End If
Next cCol
If FoundACellDiff Then
Exit For
End If
Next cRow
If FoundACellDiff = False Then
FoundAGroupMatch = True
Exit For
End If
Next iRow

If FoundAGroupMatch = True Then
MsgBox "This log has already been copied to the database",
vbExclamation
'exit sub '????
Else
'do the copy
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
DestCell.Resize(RngToCopy.Rows.Count, _
RngToCopy.Columns.Count).Value _
= RngToCopy.Value
MsgBox "All Today's Jobs Added Successfully !", vbInformation
End If
End With

End Sub

Many thanks
Anthony

--

Dave Peterson

VBA Code please
 

Thanks Dave - that worked fine

"Dave Peterson" wrote:

Maybe just add this kind of thing near the top:


If Time < TimeSerial(22, 0, 0) Then
MsgBox "It's too early!"
Exit Sub
End If

Or....

If (Time TimeSerial(4, 0, 0)) _
And (Time < TimeSerial(22, 0, 0)) Then
MsgBox "It's too early!"
Exit Sub
End If

If you want to allow from 10PM to 4AM.



Anthony wrote:

Hi 'Experts'

I was given the following code several weeks back and it works fine.
Basicaly once a macro button is selected the code will add all the data on a
worksheet to a 'database',(another worksheet)
Can somebody show me (as I am the novice) how to change this code so that
once the macro button is selected a 'time' check is made so that no data will
be added to the database before - lets say 10pm.
If the user selects this macro and the time IS before 10pm a msg box pops up
advising so, or if after 10pm all the jobs are added.
Hope that souns ok, and hope you can help.
here is the code (donated and tweeked a little)

Sub add_Anydays_jobs()

Dim DataWks As Worksheet
Dim LogWks As Worksheet
Dim FoundACellDiff As Boolean
Dim FoundAGroupMatch As Boolean
Dim RngToCopy As Range
Dim testRng As Range
Dim iRow As Long
Dim FirstRowToCheck As Long
Dim LastRowToCheck As Long
Dim cCol As Long
Dim cRow As Long
Dim DestCell As Range

Set DataWks = Worksheets(ActiveSheet.Name)
Set LogWks = Worksheets("Log")
Set RngToCopy = DataWks.Range("a8:n34")

With LogWks
FirstRowToCheck = 5 'headers?
LastRowToCheck = .Cells(.Rows.Count, "A").End(xlUp).Row
FoundAGroupMatch = False
For iRow = FirstRowToCheck To LastRowToCheck
'topleftcell of possible range to paste
Set testRng = .Cells(iRow, "A")
FoundACellDiff = False
For cRow = 1 To RngToCopy.Rows.Count
For cCol = 1 To RngToCopy.Columns.Count
If CStr(RngToCopy.Cells(cRow, cCol).Value) _
= CStr(testRng.Cells(cRow, cCol).Value) Then
'still the same
'so do nothing
Else
If CStr(RngToCopy.Cells(cRow, 2).Value) < "" Then
FoundACellDiff = True
End If
Exit For
End If
Next cCol
If FoundACellDiff Then
Exit For
End If
Next cRow
If FoundACellDiff = False Then
FoundAGroupMatch = True
Exit For
End If
Next iRow

If FoundAGroupMatch = True Then
MsgBox "This log has already been copied to the database",
vbExclamation
'exit sub '????
Else
'do the copy
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
DestCell.Resize(RngToCopy.Rows.Count, _
RngToCopy.Columns.Count).Value _
= RngToCopy.Value
MsgBox "All Today's Jobs Added Successfully !", vbInformation
End If
End With

End Sub

Many thanks
Anthony

--

Dave Peterson