LinkBack Thread Tools Search this Thread Display Modes
Prev Previous Post   Next Post Next
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 14
Default Array problem

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
 
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules

Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On


Similar Threads
Thread Thread Starter Forum Replies Last Post
Array Problem Scott Excel Discussion (Misc queries) 4 May 9th 06 05:22 PM
VBA array problem cjsmith22[_7_] Excel Programming 5 November 13th 05 12:32 AM
Array problem: Key words-Variant Array, single-element, type mismatch error davidm Excel Programming 6 November 9th 05 05:54 AM
Array problem: Key words-Variant Array, single-element, type mismatch error davidm Excel Programming 1 November 8th 05 04:21 AM
array use problem NikkoW Excel Programming 5 May 5th 04 01:32 AM


All times are GMT +1. The time now is 11:50 PM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
Copyright ©2004-2025 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"