Subtotalling multiple workbooks using access vba not working for time fields

[mindbender]

I receive the time data in seconds and format it in a query to Format([Dials and TT_week].[TT In]/86000),"hh:nn:ss" to get it to show as Hours:minutes:seconds.



The results look like this


I then use the following code to split the results into separate spreadsheets for each manager.

Option Compare Database
Function split_export()
 Dim dbs As DAO.Database
 Dim strSQL As String
 Dim rs As DAO.Recordset
    On Error Resume Next
    Kill "C:\Automation\Aspect_Reports\*.xl*"
    On Error GoTo 0
 
 Set dbs = CurrentDb
 strSQL = "SELECT DISTINCT [Manager] FROM qry_Monthly_Export_Final " & "ORDER BY [Manager]"
 Set rs = dbs.OpenRecordset(strSQL, dbOpenDynaset)
 While Not rs.EOF
 strSQL = "SELECT * FROM qry_Monthly_Export_Final " _
 & "WHERE [Manager] = '" & rs("Manager") & "'"
 dbs.QueryDefs("qry_ExportCopy_Final").SQL = strSQL
 DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, _
 "qry_ExportCopy_Final", _
 "C:\Automation\Aspect_Reports\" & rs("Manager") & ".xlsx"
 rs.MoveNext
 Wend
rs.Close
 Set rs = Nothing
 End Function

Then I use the following code to open each worksheet that was created from the step above and bold the header, autofit the column and subtotal on Column 2

Option Compare Database
Function split_Update()
 Dim dbs As DAO.Database
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String, Fnum As Long
    Dim mybook As Workbook
    Dim CalcMode As Long
    Dim sh As Worksheet
    Dim ErrorYes As Boolean
    Dim rng As Range
    Dim cell As Range
 Set dbs = CurrentDb
    'Fill in the path\folder where the files are
    MyPath = "C:\Automation\Aspect_Reports"
    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If
    'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        
    End If
    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop
    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
       ' .Calculation = xlCalculationManual
       ' .ScreenUpdating = False
        '.EnableEvents = False
    End With
    'Loop through all files in the array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0
            If Not mybook Is Nothing Then

                'Change cell value(s) in one worksheet in mybook
                On Error Resume Next
                With mybook.Worksheets(1)
                    If .ProtectContents = False Then
                    ActiveSheet.Range("1:1").Font.Bold = True
                    ActiveSheet.Range("1:1").EntireColumn.AutoFit
                  Selection.TextToColumns DataType:=xlDelimited
                    Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4, 5, 6, 7, 8, 9, 10)
                    
                    Else
                        ErrorYes = True
                    End If
                End With

                If Err.Number > 0 Then
                    ErrorYes = True
                    Err.Clear
                    'Close mybook without saving
                    mybook.Close savechanges:=False
                Else
                    'Save and close mybook
                    mybook.Close savechanges:=True
                End If
                On Error GoTo 0
            Else
                'Not possible to open the workbook
                ErrorYes = True
            End If
        Next Fnum
    End If
    If ErrorYes = True Then
        MsgBox "There are problems in one or more files, possible problem:" _
             & vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
    End If
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        '.ScreenUpdating = True
        '.EnableEvents = True
        '.Calculation = CalcMode
    End With
 End Function

It all works as expected except the time columns. They come in looking like this. Basically the subtotals for the time columns are 0 instead of the sum of the times.


In playing around in Excel, if I go to Text to Columns, choose delimited, remove all delimiters and hit finish it then totals the time showing it in seconds. Then I format the field to hh:mm:ss and it displays the results as I would expect.

Is there a way to do the text to columns and formatting bit at the same time it is bolding the first line and subtotaling the worksheets? Or is there a better way to do this?

Thanks in advance

[Bulzie]

Looks like those time columns are text, not datetime? Maybe try TimeValue function?
DateDiff("n", TimeValue(Prev_Week_TT_In), TimeValue(Prev_Week_TT_Out)) Or I could be way off.

[mindbender]

Looks like those time columns are text, not datetime? Maybe try TimeValue function?
DateDiff("n", TimeValue(Prev_Week_TT_In), TimeValue(Prev_Week_TT_Out)) Or I could be way off.

TT_In is inbound and TT_Out is outbound so these are independent values and not used to find a difference between the two.

But I do think it is a text field issue for sure. l Just not sure how to handle it

[Bulzie]

Make query out of table add new fields like vPrev_Week_TT_In: TimeValue([Prev_Week_TT_In) and one for the Out field. Then use those instead of the real fields on your form and to do the totals.

[mindbender]

Make query out of table add new fields like vPrev_Week_TT_In: TimeValue([Prev_Week_TT_In) and one for the Out field. Then use those instead of the real fields on your form and to do the totals.

I have tried this with the fields being Short Text, Number and Date/Time and I always get a type conversion failure.

I must be missing something

[mindbender]

I added the following line to the code and got it to work YAHOO!!!

ActiveSheet.Columns("F").TextToColumns Destination:=.Range("F1:F20000"), DataType:=xlDelimited