crazy export function

Private Sub export2()
If Not BasicInclude.DebugMode Then On Error GoTo Error_Handler Else On Error GoTo 0
'On Error GoTo Error_Handler
Dim app As Object
Dim w As Object
Dim sh As Object
Dim iCols As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim c As Long
Dim d As Long
Dim e As Boolean
Dim s(5) As String
Dim v() As Variant
Const xlCenter = -4108
Dim q As Variant
Dim qu As Long
Dim r As Variant
Dim t As Variant
Dim out() As Variant
Dim TidList As Variant
Dim rs() As ADODB.Recordset
Dim count As Long
Dim f As Field
Dim v2 As Variant
Dim counter As Long
Dim mem() As Variant
Dim DescGroup As Long
Dim ubrs As Long
If Me.lstTestType.ItemsSelected.count > 0 And Trim(Me.cmbPartNumber & "") <> "" Then
    Set app = CreateObject("Excel.Application")
    app.ScreenUpdating = False
    app.Visible = False
    Set w = app.Workbooks.Add()
    For i = 0 To lstTestType.ItemsSelected.count - 1
        'Set sh = w.Sheets(1)
        'Set rs2(0) = New ADODB.Recordset
        'Set rs = rs2(0)
        'the parameter list is as follows
        '0 = part number
        '1 = test type
        '2 = serial number start
        '3 = serial number end
        '4 = date start
        '5 = date end
        s(0) = Me.cmbPartNumber
        s(1) = Me.lstTestType.Column(0, Me.lstTestType.ItemsSelected(i))
        If Me.txtFirst & "" <> "" Then
            s(2) = Me.txtFirst
            If Me.txtLast & "" = "" Then
            s(3) = Me.txtFirst
            Else
            s(3) = Me.txtLast
            End If
        Else

            s(2) = 0
            s(3) = 99999999
        End If
        If Me.txtStart & "" = "" Then
        s(4) = DateSerial(Year(Now) - 20, Month(Now), Day(Now))
        Else
        s(4) = DateValue(Me.txtStart) & " 12:00:00 AM"
        End If
        If Me.txtEnd & "" = "" Then
        s(5) = DateSerial(Year(Now) + 20, Month(Now), Day(Now))
        Else
        s(5) = DateValue(Me.txtEnd) & " 11:59:59 PM"
        End If
        TidList = Qlookup("qry" & Me.lstTestType.Column(1, Me.lstTestType.ItemsSelected(i)) & "Header", s)
        If Not IsNull(TidList) Then
            Debug.Print
            q = Qlookup("qry" & Me.lstTestType.Column(1, Me.lstTestType.ItemsSelected(i)) & "Descriptions", s)
            qu = UBound2(q)
            DescGroup = qu
            ReDim rs(qu) As ADODB.Recordset
            ReDim mem(qu, 1, 100) As Variant
            For j = 0 To qu
                Set rs(j) = New ADODB.Recordset
                rs(j).Fields.Append "PartNumber", adVarChar, 35, adFldKeyColumn
                rs(j).Fields.Append "SerialNumber", adInteger, , adFldKeyColumn
                rs(j).Fields.Append "TestType", adVarChar, 35
                rs(j).Fields.Append "TestDate", adDate, , adFldKeyColumn
                rs(j).Fields.Append "Good", adChar, 1
                d = 0
                On Error Resume Next
                    For k = 0 To UBound2(q, 2) - 1
                        If Trim(q(j, k) & "") <> "" Then
                            c = 0
                            e = False
                            Do
                            Err.Clear
                                If c = 0 Then
                                    rs(j).Fields.Append Trim(q(j, k)), adDouble, , adFldIsNullable
                                Else
                                    rs(j).Fields.Append Trim(q(j, k)) & c, adDouble, , adFldIsNullable
                                    e = True
                                End If
                                c = c + 1
                            Loop Until Err.Number = 0
                            c = c - 1
                            If e Then
                            mem(j, 0, d) = Trim(q(j, k))
                            mem(j, 1, d) = k + 6
                            d = d + 1
                            End If
                        End If
                    Next
                On Error GoTo Error_Handler
            rs(j).Open
            Next

            Debug.Print
'-----------------I think this is where the error is-----------------------------------------------------------------
            r = Qlookup("qry" & Me.lstTestType.Column(1, Me.lstTestType.ItemsSelected(i)) & "DescriptionsAndData", s)
            qu = UBound2(r)
            ubrs = UBound2(rs)
            For j = 0 To qu
                If ubrs > 0 Then
                    DescGroup = GetDescGroupNumber(r, j, q)
                Else
                    DescGroup = 0
                End If
                If DescGroup > -1 Then
                    rs(DescGroup).AddNew
                    rs(DescGroup).Fields("SerialNumber").Value = TidList(j, 0)
                    rs(DescGroup).Fields("TestDate").Value = TidList(j, 1)
                    rs(DescGroup).Fields("PartNumber").Value = Me.cmbPartNumber
                    rs(DescGroup).Fields("TestType").Value = Me.lstTestType.Column(0, Me.lstTestType.ItemsSelected(i))
                    rs(DescGroup).Fields("Good").Value = TidList(j, 2)
                    On Error Resume Next
                    For k = 0 To UBound(r, 2) - 1 Step 2
                        If Trim(r(j, k) & "") <> "" Then
                            If IsNull(rs(DescGroup).Fields(Trim(r(j, k))).Value) Then
                                rs(DescGroup).Fields(Trim(r(j, k))).Value = Trim(r(j, k + 1))
                            Else
                                c = 0
                                Do
                                    c = c + 1
                                Loop Until IsNull(rs(DescGroup).Fields(Trim(r(j, k)) & c).Value)
                                rs(DescGroup).Fields(Trim(r(j, k)) & c).Value = Trim(r(j, k + 1))
                            End If
                        End If
                        If Err.Number <> 0 Then
                            Debug.Print Err.Source & " " & Err.Number & " " & Err.Description
                            Err.Clear
                        End If
                    Next
                    On Error GoTo Error_Handler
                    rs(DescGroup).Update
                Else
                    Debug.Print "Somehow there is no matching description group"
                End If
            Next
'--------------------------------------------------------------------------------------------------------------------
            Debug.Print
            On Error GoTo 0
            For j = 0 To UBound2(q)
            With rs(j)
            If .RecordCount <> 0 Then
                Set sh = w.Sheets(1)
                v2 = Right(Me.lstTestType.Column(1, Me.lstTestType.ItemsSelected(i)), 2)
                If v2 = "00" Then v2 = "100"
                sh.Name = s(0) & " ITD " & v2 & " " & Me.lstTestType.Column(0, Me.lstTestType.ItemsSelected(i)) & IIf(UBound2(q) <> 0, " " & j, "")
                'Build our Header
                For iCols = 0 To .Fields.count - 1
                    sh.Cells(1, iCols + 1).numberformat = "@"
                    sh.Cells(1, iCols + 1).Value = .Fields(iCols).Name
                Next
                With sh.Range(sh.Cells(1, 1), _
                                       sh.Cells(1, .Fields.count))
                    .Font.Bold = True
                    .Font.ColorIndex = 2
                    .Interior.ColorIndex = 1
                    .HorizontalAlignment = xlCenter
                End With
                sh.Range(sh.Cells(2, 1), sh.Cells(.RecordCount + 1, 3)).numberformat = "@"
                sh.Range(sh.Cells(2, 4), sh.Cells(.RecordCount + 1, .Fields.count)).numberformat = "0.0000"
                'Copy the data from our query into Excel
                sh.Range("A2").CopyFromRecordset rs(j)
                sh.Range("A1").SELECT  'Return to the top of the page

                If mem(j, 0, 0) & "" <> "" Then
                    For k = 0 To UBound2(mem, 3)
                        If mem(j, 0, k) & "" <> "" Then
                        sh.Cells(1, mem(j, 1, k)).Value = mem(j, 0, k)
                        Else
                        Exit For
                        End If

                    Next
                End If
                sh.Range(sh.Cells(1, 1), sh.Cells(.RecordCount, .Fields.count)).Columns.AutoFit    'Resize our Columns based on the headings
                    w.Sheets.Add
                app.activewindow.splitcolumn = 0
                app.activewindow.splitrow = 1
                app.activewindow.freezepanes = True
            End If
            End With
            Next


            'Else
            'MsgBox "code note implemented to handle 2 sets of data"

            'End If
        Else
        counter = counter + 1
        End If
    Next
    For Each sh In w.Sheets
                If sh.Name Like "Sheet*" And w.Sheets.count > 1 Then
                    w.Sheets(sh.Name).Delete
                End If
    Next
    If counter = Me.lstTestType.ItemsSelected.count Then
    app.Quit
    MsgBox "No Data Found."
    Else
    app.ScreenUpdating = True
    app.Visible = True
    End If
Else
    MsgBox "Please choose a part and test."
End If
Error_Exit:
Set app = Nothing
Exit Sub
Error_Handler:
If Not app Is Nothing Then
app.Quit
End If

MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: " & Err.Source & vbCrLf & _
           "Error Description: " & Err.Description _
           , vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Exit
End Sub