locked
[Excel 2k3 + VBA] Render data from Access not working RRS feed

  • Question

  • Hi,

    I have Access 2k3 database and Excel is pulling data from it and rendering it in a formatted spreadsheet;

    The problem is that the rendering is corrupted, some stuff appear in the wrong place, some other not...

    This is the Generate Button that pull the data from Access and lend it in Excel:

    Dim dates As DAO.recordset
    Dim handles, rs As DAO.recordset
    Dim db, dbspec As DAO.Database
    Dim emp, filter As String
    Dim q, w As Variant
    Dim ctype(1 To 15) As String
    Dim pause As Boolean
    
    
    Dim tier As Integer
    
    Private Sub combobox1_change()
    
    End Sub
    
    
    
    Private Sub BEFORE_Click()
    AFTER.Caption = dates.fields(0)
    dates.MoveNext
    AFTER.Visible = True
    
    Call listutd(dates.fields(0))
    
    dates.MoveNext
    If dates.EOF Then
    BEFORE.Visible = False
    Else
    BEFORE.Caption = dates.fields(0)
    End If
    dates.MovePrevious
    
    End Sub
    
    Public Sub AFTER_Click()
    BEFORE.Caption = dates.fields(0)
    dates.MovePrevious
    BEFORE.Visible = True
    
    Call listutd(dates.fields(0))
    
    dates.MovePrevious
    If dates.BOF Then
    AFTER.Visible = False
    Else
    AFTER.Caption = dates.fields(0)
    End If
    dates.MoveNext
    
    End Sub
    
    Public Sub userform_activate()
    Me.Caption = "Call Lookup - " & ActiveSheet.name
    Set db = OpenDatabase(tset(""))
    'If ActiveSheet.name = "Input" or Then
    TextBox1.Visible = False
    TextBox2.Visible = False
    TextBox3.Visible = False
    
    
    
    pause = True
    Label3.Caption = "Agent"
    Label2.Visible = False
    
    PICK.Visible = False
    DROP.Visible = False
    BEFORE.Visible = False
    AFTER.Visible = False
    LOAD.Visible = False
    LEVEL.Visible = False
    Label1.Caption = "Call Type"
    
    '*****************************************************************
    '* Look for all available locations
    '*****************************************************************
    CC.Clear
    CC.AddItem "-"
            filter = "SELECT DISTINCT LOCATION FROM VENDOR"
                Set rs = db.OpenRecordset(filter, dbReadOnly)
            With rs
            If Not .BOF Then .MoveFirst
            While Not .EOF
            CC.AddItem .fields(0)
            .MoveNext
            Wend
            End With
            rs.Close
            Set rs = Nothing
    
    
    pause = False
    CC.Text = Sheets("Input").CC
    MM.Text = Sheets("Input").MM
    EE.Text = Sheets("Input").EE
    'Else
    
    'End If
    End Sub
    
    Public Sub CC_change()
    If Not pause Then
    pause = True
    Dim rsemp As DAO.recordset
    MM.Clear
    MM.AddItem "-"
    EE.Clear
    EE.AddItem "-"
            filter = "SELECT DISTINCT BOSS FROM VENDOR WHERE LOCATION = '" & CC.Text & "'"
                Set rsemp = db.OpenRecordset(filter, dbReadOnly)
            With rsemp
            If Not .BOF Then .MoveFirst
            While Not .EOF
            MM.AddItem .fields(0)
            .MoveNext
            Wend
            End With
            rsemp.Close
            Set rsemp = Nothing
    MM.Text = "-"
    EE.Text = "-"
    ListBox1.Clear
    BEFORE.Visible = False
    AFTER.Visible = False
    PICK.Visible = False
    DROP.Visible = False
    LOAD.Visible = False
    
    pause = False
    End If
    End Sub
    Private Sub MM_change()
    If Not pause Then
    pause = True
    Dim rsemp As DAO.recordset
    EE.Clear
    EE.AddItem "-"
            filter = "SELECT DISTINCT CUSTOMER FROM VENDOR WHERE BOSS = '" & MM.Text & "'"
                Set rsemp = db.OpenRecordset(filter, dbReadOnly)
            With rsemp
            If Not .BOF Then .MoveFirst
            While Not .EOF
            EE.AddItem .fields(0)
            .MoveNext
            Wend
            End With
            rsemp.Close
            Set rsemp = Nothing
    EE.Text = "-"
    ListBox1.Clear
    BEFORE.Visible = False
    AFTER.Visible = False
    PICK.Visible = False
    DROP.Visible = False
    LOAD.Visible = False
    pause = False
    End If
    End Sub
    Private Sub EE_change()
    If Not pause Then
    pause = True
    If Not EE.Text = "-" Then refresh
    BEFORE.Visible = False
    AFTER.Visible = False
    PICK.Visible = False
    DROP.Visible = False
    LOAD.Visible = False
    pause = False
    End If
    End Sub
    
    Public Sub refresh()
    Label1.Caption = "Call Type"
    ListBox1.Clear
    Dim db2 As DAO.Database
    
    filter = "SELECT * FROM Table1 WHERE CUSTOMER = '" & EE.Text & "'"
    Dim added As Boolean
    
    For x = 0 To Sheets("Input").ctype.ListCount - 1
    If InStr(Sheets("Input").ctype.List(x), " - ") Then
    q = Split(Sheets("Input").ctype.List(x), " - ")
    added = False
    DoEvents
    For y = 0 To ListBox1.ListCount - 1
    If InStr(ListBox1.List(y), q(0)) Then added = True
    Next y
    If Not added Then
    
    Set db2 = OpenDatabase(tset(q(0)), False, True, "MS Access;pwd=ct_2010")
    Set rs = db2.OpenRecordset(filter, dbReadOnly)
    If Not rs.BOF Then rs.MoveFirst
    While Not rs.EOF
    rs.MoveNext
    Wend
    If Label1.Caption = "Call Type" Then ListBox1.AddItem q(0) & " - #" & rs.RecordCount
    rs.Close
    Set rs = Nothing
    db2.Close
    Set db2 = Nothing
    End If
    End If
    Next x
    
    End Sub
    Private Sub ListBox1_change()
    If Not pause Then
    If Label1.Caption = "Call Type" Then
    If InStr(ListBox1.List(ListBox1.ListIndex), "#0") = 0 Then
    LEVEL.Visible = True
    Else
    LEVEL.Visible = False
    End If
    End If
    Else
    
    
    End If
    End Sub
    Private Sub LEVEL_Click()
    If Not pause Then
    pause = True
    If LEVEL.Caption = "Select" Then
    Label1.Caption = ListBox1.List(ListBox1.ListIndex)
    For x = 0 To ListBox1.ListCount - 1
    If x <= 14 Then ctype(x + 1) = ListBox1.List(x)
    Next x
    ListBox1.Clear
    PICK.Visible = True
    If ActiveSheet.name = "Input" Then
    TextBox1.Visible = True
    ElseIf ActiveSheet.name = "Report" Then
    TextBox1.Visible = True
    TextBox2.Visible = True
    TextBox3.Visible = True
    End If
    LEVEL.Caption = "Back"
    If InStr(Label1.Caption, " - ") Then
    q = Split(Label1.Caption, " - ")
    Set dbspec = OpenDatabase(tset(q(0)), False, True, "MS Access;pwd=ct_2010")
    call_list
    End If
    Else
    LEVEL.Caption = "Select"
    LEVEL.Visible = False
    PICK.Visible = False
    TextBox1.Visible = False
    TextBox1.Text = ""
    TextBox2.Visible = False
    TextBox2.Text = ""
    TextBox3.Visible = False
    TextBox3.Text = ""
    BEFORE.Visible = False
    AFTER.Visible = False
    dbspec.Close
    Set dbspec = Nothing
    ListBox1.Clear
    Label1.Caption = "Call Type"
    For x = 1 To 15
    If Not ctype(x) = "" Then ListBox1.AddItem ctype(x)
    Next x
    End If
    pause = False
    End If
    End Sub
    
    Public Sub call_list()
    Dim f2 As String
    
    f2 = "SELECT DISTINCT PURCH_DATE FROM Table1 WHERE CUSTOMER = '" & EE.Text & "' ORDER BY PURCH_DATE DESC"
    
    Set dates = dbspec.OpenRecordset(f2, dbReadOnly)
    If Not dates.BOF Then dates.MoveFirst
    If Not dates.EOF Then
    Call listutd(dates.fields(0))
    End If
    
    dates.MoveNext
    If dates.EOF Then
    BEFORE.Visible = False
    Else
    BEFORE.Visible = True
    BEFORE.Caption = dates.fields(0)
    End If
    dates.MovePrevious
    
    AFTER.Visible = False
    LOAD.Visible = False
    
    End Sub
    
    Public Function listutd(a) As Long
    Dim handle As String
    filter = "SELECT handle, FORMAL, CALL_TYPE FROM Table1 WHERE CUSTOMER = '" & EE.Text & "' AND PURCH_DATE = #" & a & "#"
    
    Set handles = dbspec.OpenRecordset(filter, dbReadOnly)
    ListBox1.Clear
    
        
        With handles
        If Not .BOF Then .MoveFirst
        While Not .EOF
        w = Split(.fields(2), " - ")
        handle = .fields(1) & " - #" & .fields(0) & " - " & w(1)
        
        If Not ((handle = TextBox1.Text) Or (handle = TextBox2.Text) Or (handle = TextBox3.Text)) Then
        ListBox1.AddItem handle
        End If
        
        .MoveNext
        Wend
        listutd = .RecordCount
        End With
    handles.Close
    Set handles = Nothing
    End Function
    
    Private Sub PICK_Click()
    If ActiveSheet.name = "Input" Then
        TextBox1.Text = ListBox1.Value
        PICK.Visible = False
        DROP.Visible = True
        LOAD.Visible = True
        LOAD.Caption = "Load"
        Call listutd(dates.fields(0))
    Else
    If Not ListBox1.Value = "" Then
        If TextBox1.Value = "" Then
        TextBox1.Text = ListBox1.Value
        LOAD.Visible = True
        ElseIf TextBox2.Value = "" Then
        TextBox2.Text = ListBox1.Value
        ElseIf TextBox3.Value = "" Then
        TextBox3.Text = ListBox1.Value
        PICK.Visible = False
        End If
        DROP.Visible = True
    Call listutd(dates.fields(0))
    End If
    End If
    End Sub
    
    Private Sub DROP_Click()
    If ActiveSheet.name = "Input" Then
        TextBox1.Text = ""
        PICK.Visible = True
        DROP.Visible = False
        LOAD.Visible = False
        Call listutd(dates.fields(0))
    Else
        If Not TextBox3.Value = "" Then
        TextBox3.Text = ""
        PICK.Visible = True
        ElseIf Not TextBox2.Value = "" Then
        TextBox2.Text = ""
        ElseIf Not TextBox1.Value = "" Then
        TextBox1.Text = ""
        LOAD.Visible = False
        End If
    Call listutd(dates.fields(0))
    End If
    End Sub
    
    Private Sub LOAD_Click()
        global_pause = True
        '** COPY THE LOCATION LIST TO THE SHEET
        Sheets("Input").CC.Clear
        For x = 0 To CC.ListCount - 1
        Sheets("Input").CC.AddItem CC.List(x)
        Next x
        Sheets("Input").CC.Text = CC.Text
        '** COPY THE BOSS LIST TO THE SHEET
        Sheets("Input").MM.Clear
        For x = 0 To MM.ListCount - 1
        Sheets("Input").MM.AddItem MM.List(x)
        Next x
        Sheets("Input").MM.Text = MM.Text
        '** COPY THE CUSTOMER LIST TO THE SHEET
        Sheets("Input").EE.Clear
        For x = 0 To EE.ListCount - 1
        Sheets("Input").EE.AddItem EE.List(x)
        Next x
        Sheets("Input").EE.Text = EE.Text
        global_pause = False
    
    If ActiveSheet.name = "Input" Then
    
        q = Split(TextBox1.Text, " - ")
        filter = "SELECT * FROM Table1 WHERE"
        For x = 0 To UBound(q)
        If Left(q(x), 1) = "#" Then filter = filter & " handle = " & Right(q(x), Len(q(x)) - 1)
        Next x
        Set handles = dbspec.OpenRecordset(filter, dbReadOnly)
            
        callinfo = handles.GetRows(1)
        For x = 0 To UBound(callinfo, 1)
        call_key(x) = handles.fields(x).name
        Next x
        
        handles.Close
        Set handles = Nothing
        
        
        dates.Close
        Set dates = Nothing
        dbspec.Close
        Set dbspec = Nothing
        
        Unload Me
    Else
       
        Dim ncalls As Integer
        
        filter = "SELECT * FROM Table1 WHERE"
        q = Split(TextBox1.Text, " - ")
        For x = 0 To UBound(q)
        If Left(q(x), 1) = "#" Then filter = filter & " (handle = " & Right(q(x), Len(q(x)) - 1)
        Next x
        ncalls = 1
        
        If Not TextBox2.Text = "" Then
        q = Split(TextBox2.Text, " - ")
        For x = 0 To UBound(q)
        If Left(q(x), 1) = "#" Then filter = filter & ") OR (handle = " & Right(q(x), Len(q(x)) - 1)
        Next x
        ncalls = 2
        
        If Not TextBox3.Text = "" Then
        q = Split(TextBox3.Text, " - ")
        For x = 0 To UBound(q)
        If Left(q(x), 1) = "#" Then filter = filter & ") OR (handle = " & Right(q(x), Len(q(x)) - 1)
        Next x
        ncalls = 3
        End If
        End If
        filter = filter & ")"
    
        
        Set handles = dbspec.OpenRecordset(filter, dbReadOnly)
            
        callinfo = handles.GetRows(ncalls)
        For x = 0 To UBound(callinfo, 1)
        call_key(x) = handles.fields(x).name
        Next x
        
        handles.Close
        Set handles = Nothing
    
    dates.Close
    Set dates = Nothing
    db.Close
    Set db = Nothing
    
    Unload Me
    End If
    End Sub
    
    


    How can I fix this, please?

    Regards

    Thursday, December 1, 2011 9:39 PM

All replies

  • Dear Admin-Dev,

    >>The problem is that the rendering is corrupted, some stuff appear in the wrong place, some other not
    What  do you mean about this? What do you mean about "some stuff appear in the wrong place, some other not..."? Could you give more details about this?

    You'd better send your files to the skydrive:https://skydrive.live.com/ so that I can test on my side and try to give you the workarounds.

    Regards,

     


    Be happy.
    Wednesday, December 7, 2011 1:38 AM