Ниже приведен код, который в основном копирует данные из одного листа Excel в другой лист Excel и прекрасно работает, выполняя свою работу. Я хочу получить дополнительный контроль в приведенном ниже коде.
В моем табеле времени я запретить людям обновлять информацию более чем за один день, например: если я обновляю информацию за 1 мая и если Excel содержит информацию за несколько дней (1,2,3,4 мая), она должна обновляться только за 1 мая. Любую логи c я могу добавить как команду ввода или ссылку на любую ячейку до даты с префиксом.
Sub UpdateSummary()
Dim cn As Object, cm As Object, rs As Object
Dim dte As Double, nme As String, activity As String, sub_activity As String, upt_time As Integer, comments As String
Dim lr As Long
Dim cc As Range
On Error GoTo err_handler
Set cn = CreateObject("ADODB.Connection")
Set cm = CreateObject("ADODB.Command")
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Data Source") = ThisWorkbook.Path & "\Summary-TimeSheet.xlsm"
.Properties("Extended Properties") = "Excel 12.0 Macro; HDR=YES; IMEX=0"
.Open
End With
cm.ActiveConnection = cn
cm.CommandText = "SELECT Name,Date FROM [Summary$] WHERE Name = '" & ActiveSheet.Range("B2") & "' AND Date = " & CDbl(ActiveSheet.Range("A2"))
Set rs = cm.Execute
If Not (rs.BOF And rs.EOF) Then
MsgBox "Data for this date has already been submitted", vbInformation
Exit Sub
End If
With ActiveSheet
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each cc In .Range("A2:A" & lr)
dte = CDbl(cc.Offset(0))
nme = cc.Offset(, 1)
activity = cc.Offset(, 2)
sub_activity = cc.Offset(, 3)
upt_time = CDbl(cc.Offset(, 4))
comments = cc.Offset(, 5)
cm.CommandText = "INSERT INTO [Summary$] ([Date],[Name],[Activity],[Sub Activity],[UPT Time],[Comments]) VALUES (" & _
dte & ", " & _
"'" & nme & "', " & _
"'" & activity & "', " & _
"'" & sub_activity & "', " & _
upt_time & ", " & _
"'" & comments & "')"
cm.Execute
Next cc
End With
exit_handler:
Set rs = Nothing
Set cm = Nothing
Set cn = Nothing
Exit Sub
err_handler:
MsgBox "Function UpdateSummary" & vbNewLine & vbNewLine & Err.Number & ": " & Err.Description, vbCritical, "Error in Function UpdateSummary"
Resume exit_handler
End Sub