N
neil_val
Hi, I have been having all sorts of trouble with this timesheet system
problem that I have developed.I have been helped with solutions that
could have been the problem?? The problem I am encoutering is that
everytime someone submits their timesheet to the DB it misses out the
last row of data depending on how they have filled it out: ie if they
delete all the blank rows this particular code works:
If b = 12 Then b = 13
For a = 1 To (b - 11) - 1 Step 1
If they do not delete their blank rows this particular code works:
If b = 12 Then b = 13
For a = 1 To (a - 11) - 1 Step 1
I have a code that I think is the problem and I have no idea on how
arrays or even invert arrays work - here is the code:
Dim TaskData() As Variant
Call LastRow
TaskData() = Sheets("New Time Sheet").Range("A12:L" & LastR).Value
'TaskData() = Sheets("New Time Sheet").Range("A12:L12").Value
Dim Tempdata() As Variant
c = 0
For a = 1 To (LastR - 11) Step 1
'For a = 1 To 21 Step 1
'If TaskData(a, 11) = "" Then
If TaskData(a, 12) = "" Then
Else
c = c + 1
ReDim Preserve Tempdata(12, c)
''For d = 1 To (LastR - 11) Step 1
For d = 1 To 12 Step 1
Tempdata(d, c) = TaskData(a, d)
Next d
End If
Next a
'-----invert array-----
ReDim TaskData(c, 12)
For a = 1 To c Step 1
For b = 1 To 12 Step 1
TaskData(a, b) = Tempdata(b, a)
Next b
Next a
I have also copied the whole sub (module) for reference:
Dim DBFILE As String
Dim who As String
Dim dept As String
'Const DBFILE As String = "U:\Db\db1.mdb"
Sub Adddata()
'Dim DBFILE, who As String
'DBFILE = "U:\Db\db1.mdb"
DBFILE = Sheets("Setup").Range("B6").Value
sheetdate = Str$(Cells(1, 11))
who = Environ("username")
'''Call validate("New Time Sheet", sheetdate) 'Validate Data
Dim timein(1 To 7) As Variant
Dim timeout(1 To 7) As Variant
Dim timelunch(1 To 7) As Variant
Dim weekhours As Single
Dim week As Date
week = Sheets("New Time Sheet").Range("K1")
weekhours = 0
For a = 1 To 7 Step 1
timein(a) = Sheets("New Time Sheet").Cells(5, a + 2)
timelunch(a) = Sheets("New Time Sheet").Cells(6, a + 2)
timeout(a) = Sheets("New Time Sheet").Cells(7, a + 2)
weekhours = weekhours + (timeout(a) - timein(a) - timelunch(a)) *
24
Next a
Dim TaskData() As Variant
Call LastRow
TaskData() = Sheets("New Time Sheet").Range("A12:L" & LastR).Value
'TaskData() = Sheets("New Time Sheet").Range("A12:L12").Value
Dim Tempdata() As Variant
c = 0
For a = 1 To (LastR - 11) Step 1
'For a = 1 To 21 Step 1
'If TaskData(a, 11) = "" Then
If TaskData(a, 12) = "" Then
Else
c = c + 1
ReDim Preserve Tempdata(12, c)
''For d = 1 To (LastR - 11) Step 1
For d = 1 To 12 Step 1
Tempdata(d, c) = TaskData(a, d)
Next d
End If
Next a
'-----invert array-----
ReDim TaskData(c, 12)
For a = 1 To c Step 1
For b = 1 To 12 Step 1
TaskData(a, b) = Tempdata(b, a)
Next b
Next a
'----------Check to see if data exists-------------
msg = Null
Set cnn1 = CreateObject("ADODB.Connection")
openstr = "driver={Microsoft Access Driver (*.mdb)};" & _
"dbq=" & DBFILE
Set rs = CreateObject("ADODB.Recordset")
Sql = "SELECT Sum([HoldingTable].[TotalHrs]) AS TOTAL, [HoldingTable].
[EmployeesName], [HoldingTable].[WkComDate], [HoldingTable].
[Department] " & _
"FROM [HoldingTable] " & _
"GROUP BY [HoldingTable].[EmployeesName], [HoldingTable].[WkComDate],
[HoldingTable].[Department] " & _
"HAVING [HoldingTable].[EmployeesName]='" & who & "';"
'"HAVING ((([Holding Table].[EmployeeName])='" & who & "') AND
((HoldingTable.DATE)=#" & Format(week, "mm/dd/yyyy") & "#));"
On Error GoTo error1
cnn1.Open openstr, "", ""
rs.Open Sql, cnn1, 2, 2, 1
On Error GoTo 0
err = 0
If rs.RecordCount <> -1 Then
If rs!WkComDate <> week Then
err = 0
Else
msg = msg & "Data already exists for this period" & Chr(13) &
Chr(13)
Do While Not rs.EOF
msg = msg & Format(rs("Total"), "0.0") & " Hours Submitted
Already" & vbCrLf
rs.movenext
Loop
err = 1
End If
rs.Close
cnn1.Close
Set cnn1 = Nothing
Set rs = Nothing
msg = msg & Chr(13) & Chr(13) & "Overwrite existing data?"
If err = 1 Then err = MsgBox(msg, vbYesNo)
Else
If err = 7 Then
MsgBox ("Submission aborted")
End
Else
Call enterdatatimeinout(week, timein(), timeout(), timelunch(),
who)
Call enterdatatask(week, TaskData(), who)
msg = weekhours & " - Hours Submitted into Database"
MsgBox (msg)
End If
End If
''''End
Exit Sub
error1:
MsgBox ("Error: Please check the location of the Database")
Stop
End Sub
Sub enterdatatimeinout(week, timein(), timeout(), timelunch(), who)
Set cnn1 = CreateObject("ADODB.Connection")
openstr = "driver={Microsoft Access Driver (*.mdb)};" & _
"dbq=" & DBFILE
'openstr = "driver={Microsoft Access Driver (*.mdb)};" & _
"dbq=U:\db\db1.mdb"
Set rs = CreateObject("ADODB.Recordset")
Sql = "SELECT TIMEINOUT.* FROM TIMEINOUT " & _
"WHERE (((TIMEINOUT.EMPLOYEESNAME)='" & who & "') AND
((TIMEINOUT.DATE)>= #" & Format(week, "mm/dd/yyyy") & "# " & _
"AND (TIMEINOUT.DATE)<= #" & Format((week + 6), "mm/dd/yyyy") &
"#)); "
'MsgBox (Sql)
cnn1.Open openstr, "", ""
rs.Open Sql, cnn1, 2, 2, 1
If rs.EOF Then
Else
Do While Not rs.EOF
rs.Delete
rs.movefirst
Loop
End If
For a = 1 To 7 Step 1
rs.addnew
rs("DATE") = week + a - 1
rs("TIMEIN") = timein(a)
rs("TIMELUNCH") = timelunch(a)
rs("TIMEOUT") = timeout(a)
rs("EMPLOYEESNAME") = who
'rs("DEPARTMENT") = dept
rs("DATESUBMITTED") = Now()
Next a
rs.update
rs.Close
cnn1.Close
Set cnn1 = Nothing
Set rs = Nothing
'MsgBox (msg)
End Sub
Sub enterdatatask(week, HoldingTableData(), who)
Set cnn1 = CreateObject("ADODB.Connection")
openstr = "driver={Microsoft Access Driver (*.mdb)};" & _
"dbq=\\dsuk01\DO Administration$\DO Timesheets\Timesheets
\DO.mdb"
openstr = "driver={Microsoft Access Driver (*.mdb)};" & _
"dbq=" & DBFILE
'MsgBox cnn1
Set rs = CreateObject("ADODB.Recordset")
Sql = "SELECT HOLDINGTABLE.* FROM HOLDINGTABLE " & _
"WHERE (((HOLDINGTABLE.EMPLOYEESNAME)='" & who & "') AND
((HOLDINGTABLE.WKCOMDATE)= #" & Format(week, "mm/dd/yyyy") & "#));"
cnn1.Open openstr, "", ""
rs.Open Sql, cnn1, 2, 2, 1
If rs.EOF Then
Else
Do While Not rs.EOF
rs.Delete
rs.movefirst
Loop
End If
Worksheets("New Time Sheet").Activate
Dim b As Integer
For a = 12 To 100
If Range("A" & a) = "" Then
b = a - 1
Exit For
Else
End If
Next a
'Stop
If b = 12 Then b = 13
For a = 1 To (a - 11) - 1 Step 1
'For a = 1 To (b - 11) Step 1
rs.addnew
rs("WKCOMDATE") = week
rs("PROJECTCODE") = HoldingTableData(a, 1)
rs("WORKCODE") = HoldingTableData(a, 2)
rs("MON") = HoldingTableData(a, 3)
rs("TUE") = HoldingTableData(a, 4)
rs("WED") = HoldingTableData(a, 5)
rs("THU") = HoldingTableData(a, 6)
rs("FRI") = HoldingTableData(a, 7)
rs("SAT") = HoldingTableData(a, 8)
rs("SUN") = HoldingTableData(a, 9)
rs("TOTALHRS") = HoldingTableData(a, 10)
rs("TASKCATEGORY") = HoldingTableData(a, 11)
rs("PARTNUMBER") = HoldingTableData(a, 12)
'''''rs("REPORTINGMONTH") = MonthName(Month(Date))
rs("EMPLOYEESNAME") = who
rs("DATESUBMITTED") = Date
'rs("DEPARTMENT") = dept
'rs("DATESUB") = Now()
Next a
rs.update
rs.Close
cnn1.Close
Set cnn1 = Nothing
Set rs = Nothing
'MsgBox (msg)
End Sub
'Function who()
'who = "Hello" 'Environ("username") '
'End Function
Please, please, please, any help will be soooo much appreciated.
Thanks
problem that I have developed.I have been helped with solutions that
could have been the problem?? The problem I am encoutering is that
everytime someone submits their timesheet to the DB it misses out the
last row of data depending on how they have filled it out: ie if they
delete all the blank rows this particular code works:
If b = 12 Then b = 13
For a = 1 To (b - 11) - 1 Step 1
If they do not delete their blank rows this particular code works:
If b = 12 Then b = 13
For a = 1 To (a - 11) - 1 Step 1
I have a code that I think is the problem and I have no idea on how
arrays or even invert arrays work - here is the code:
Dim TaskData() As Variant
Call LastRow
TaskData() = Sheets("New Time Sheet").Range("A12:L" & LastR).Value
'TaskData() = Sheets("New Time Sheet").Range("A12:L12").Value
Dim Tempdata() As Variant
c = 0
For a = 1 To (LastR - 11) Step 1
'For a = 1 To 21 Step 1
'If TaskData(a, 11) = "" Then
If TaskData(a, 12) = "" Then
Else
c = c + 1
ReDim Preserve Tempdata(12, c)
''For d = 1 To (LastR - 11) Step 1
For d = 1 To 12 Step 1
Tempdata(d, c) = TaskData(a, d)
Next d
End If
Next a
'-----invert array-----
ReDim TaskData(c, 12)
For a = 1 To c Step 1
For b = 1 To 12 Step 1
TaskData(a, b) = Tempdata(b, a)
Next b
Next a
I have also copied the whole sub (module) for reference:
Dim DBFILE As String
Dim who As String
Dim dept As String
'Const DBFILE As String = "U:\Db\db1.mdb"
Sub Adddata()
'Dim DBFILE, who As String
'DBFILE = "U:\Db\db1.mdb"
DBFILE = Sheets("Setup").Range("B6").Value
sheetdate = Str$(Cells(1, 11))
who = Environ("username")
'''Call validate("New Time Sheet", sheetdate) 'Validate Data
Dim timein(1 To 7) As Variant
Dim timeout(1 To 7) As Variant
Dim timelunch(1 To 7) As Variant
Dim weekhours As Single
Dim week As Date
week = Sheets("New Time Sheet").Range("K1")
weekhours = 0
For a = 1 To 7 Step 1
timein(a) = Sheets("New Time Sheet").Cells(5, a + 2)
timelunch(a) = Sheets("New Time Sheet").Cells(6, a + 2)
timeout(a) = Sheets("New Time Sheet").Cells(7, a + 2)
weekhours = weekhours + (timeout(a) - timein(a) - timelunch(a)) *
24
Next a
Dim TaskData() As Variant
Call LastRow
TaskData() = Sheets("New Time Sheet").Range("A12:L" & LastR).Value
'TaskData() = Sheets("New Time Sheet").Range("A12:L12").Value
Dim Tempdata() As Variant
c = 0
For a = 1 To (LastR - 11) Step 1
'For a = 1 To 21 Step 1
'If TaskData(a, 11) = "" Then
If TaskData(a, 12) = "" Then
Else
c = c + 1
ReDim Preserve Tempdata(12, c)
''For d = 1 To (LastR - 11) Step 1
For d = 1 To 12 Step 1
Tempdata(d, c) = TaskData(a, d)
Next d
End If
Next a
'-----invert array-----
ReDim TaskData(c, 12)
For a = 1 To c Step 1
For b = 1 To 12 Step 1
TaskData(a, b) = Tempdata(b, a)
Next b
Next a
'----------Check to see if data exists-------------
msg = Null
Set cnn1 = CreateObject("ADODB.Connection")
openstr = "driver={Microsoft Access Driver (*.mdb)};" & _
"dbq=" & DBFILE
Set rs = CreateObject("ADODB.Recordset")
Sql = "SELECT Sum([HoldingTable].[TotalHrs]) AS TOTAL, [HoldingTable].
[EmployeesName], [HoldingTable].[WkComDate], [HoldingTable].
[Department] " & _
"FROM [HoldingTable] " & _
"GROUP BY [HoldingTable].[EmployeesName], [HoldingTable].[WkComDate],
[HoldingTable].[Department] " & _
"HAVING [HoldingTable].[EmployeesName]='" & who & "';"
'"HAVING ((([Holding Table].[EmployeeName])='" & who & "') AND
((HoldingTable.DATE)=#" & Format(week, "mm/dd/yyyy") & "#));"
On Error GoTo error1
cnn1.Open openstr, "", ""
rs.Open Sql, cnn1, 2, 2, 1
On Error GoTo 0
err = 0
If rs.RecordCount <> -1 Then
If rs!WkComDate <> week Then
err = 0
Else
msg = msg & "Data already exists for this period" & Chr(13) &
Chr(13)
Do While Not rs.EOF
msg = msg & Format(rs("Total"), "0.0") & " Hours Submitted
Already" & vbCrLf
rs.movenext
Loop
err = 1
End If
rs.Close
cnn1.Close
Set cnn1 = Nothing
Set rs = Nothing
msg = msg & Chr(13) & Chr(13) & "Overwrite existing data?"
If err = 1 Then err = MsgBox(msg, vbYesNo)
Else
If err = 7 Then
MsgBox ("Submission aborted")
End
Else
Call enterdatatimeinout(week, timein(), timeout(), timelunch(),
who)
Call enterdatatask(week, TaskData(), who)
msg = weekhours & " - Hours Submitted into Database"
MsgBox (msg)
End If
End If
''''End
Exit Sub
error1:
MsgBox ("Error: Please check the location of the Database")
Stop
End Sub
Sub enterdatatimeinout(week, timein(), timeout(), timelunch(), who)
Set cnn1 = CreateObject("ADODB.Connection")
openstr = "driver={Microsoft Access Driver (*.mdb)};" & _
"dbq=" & DBFILE
'openstr = "driver={Microsoft Access Driver (*.mdb)};" & _
"dbq=U:\db\db1.mdb"
Set rs = CreateObject("ADODB.Recordset")
Sql = "SELECT TIMEINOUT.* FROM TIMEINOUT " & _
"WHERE (((TIMEINOUT.EMPLOYEESNAME)='" & who & "') AND
((TIMEINOUT.DATE)>= #" & Format(week, "mm/dd/yyyy") & "# " & _
"AND (TIMEINOUT.DATE)<= #" & Format((week + 6), "mm/dd/yyyy") &
"#)); "
'MsgBox (Sql)
cnn1.Open openstr, "", ""
rs.Open Sql, cnn1, 2, 2, 1
If rs.EOF Then
Else
Do While Not rs.EOF
rs.Delete
rs.movefirst
Loop
End If
For a = 1 To 7 Step 1
rs.addnew
rs("DATE") = week + a - 1
rs("TIMEIN") = timein(a)
rs("TIMELUNCH") = timelunch(a)
rs("TIMEOUT") = timeout(a)
rs("EMPLOYEESNAME") = who
'rs("DEPARTMENT") = dept
rs("DATESUBMITTED") = Now()
Next a
rs.update
rs.Close
cnn1.Close
Set cnn1 = Nothing
Set rs = Nothing
'MsgBox (msg)
End Sub
Sub enterdatatask(week, HoldingTableData(), who)
Set cnn1 = CreateObject("ADODB.Connection")
openstr = "driver={Microsoft Access Driver (*.mdb)};" & _
"dbq=\\dsuk01\DO Administration$\DO Timesheets\Timesheets
\DO.mdb"
openstr = "driver={Microsoft Access Driver (*.mdb)};" & _
"dbq=" & DBFILE
'MsgBox cnn1
Set rs = CreateObject("ADODB.Recordset")
Sql = "SELECT HOLDINGTABLE.* FROM HOLDINGTABLE " & _
"WHERE (((HOLDINGTABLE.EMPLOYEESNAME)='" & who & "') AND
((HOLDINGTABLE.WKCOMDATE)= #" & Format(week, "mm/dd/yyyy") & "#));"
cnn1.Open openstr, "", ""
rs.Open Sql, cnn1, 2, 2, 1
If rs.EOF Then
Else
Do While Not rs.EOF
rs.Delete
rs.movefirst
Loop
End If
Worksheets("New Time Sheet").Activate
Dim b As Integer
For a = 12 To 100
If Range("A" & a) = "" Then
b = a - 1
Exit For
Else
End If
Next a
'Stop
If b = 12 Then b = 13
For a = 1 To (a - 11) - 1 Step 1
'For a = 1 To (b - 11) Step 1
rs.addnew
rs("WKCOMDATE") = week
rs("PROJECTCODE") = HoldingTableData(a, 1)
rs("WORKCODE") = HoldingTableData(a, 2)
rs("MON") = HoldingTableData(a, 3)
rs("TUE") = HoldingTableData(a, 4)
rs("WED") = HoldingTableData(a, 5)
rs("THU") = HoldingTableData(a, 6)
rs("FRI") = HoldingTableData(a, 7)
rs("SAT") = HoldingTableData(a, 8)
rs("SUN") = HoldingTableData(a, 9)
rs("TOTALHRS") = HoldingTableData(a, 10)
rs("TASKCATEGORY") = HoldingTableData(a, 11)
rs("PARTNUMBER") = HoldingTableData(a, 12)
'''''rs("REPORTINGMONTH") = MonthName(Month(Date))
rs("EMPLOYEESNAME") = who
rs("DATESUBMITTED") = Date
'rs("DEPARTMENT") = dept
'rs("DATESUB") = Now()
Next a
rs.update
rs.Close
cnn1.Close
Set cnn1 = Nothing
Set rs = Nothing
'MsgBox (msg)
End Sub
'Function who()
'who = "Hello" 'Environ("username") '
'End Function
Please, please, please, any help will be soooo much appreciated.
Thanks