Notifications
Clear all

Erro filtro Listbox

2 Posts
1 Usuários
0 Reactions
925 Visualizações
NERI S
(@neri-s)
Posts: 0
Estimable Member
Topic starter
 

Estou com um código que desenvolvi na minha máquina que usa 32bits no Excel e o filtro funciona corretamente. Quando tento usar na máquina que é de 64bits não funciona, não dá erro mas não filtra. O que devo alterar? quando abri deu erro nas referências e desmarquei "Microsoft Windows Common Controls 6.0 (SP6)" pois constava como ausente.
O que será?

Private Sub Userform_Initialize()

    'preenche o cboDirecao e seleciona o primeiro item
    Cbodirecao.Clear
    Cbodirecao.AddItem "Ascendente"
    Cbodirecao.AddItem "Descendente"
    Cbodirecao.listindex = 0
    
    Call PopulaListBox(vbNullString, vbNullString, vbNullString, vbNullString)
    formatarcolunas
lstLista.ColumnWidths = "40;60;40;0;200;0;80;250;0;0;0;0;0;0;0;0;0"

Calculos


End Sub

Private Sub PopulaListBox(ByVal cliente As String, _
                          ByVal Mes As String, _
                          ByVal Ano As String, _
                          ByVal Cia As String)

    On Error GoTo TrataErro

    Dim conn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim sql As String
    Dim sqlWhere As String
    Dim sqlOrderBy As String
    Dim I As Integer
    Dim campo As Field
    Dim myArray() As Variant

    Set conn = New ADODB.Connection
    With conn
        .Provider = "Microsoft.JET.OLEDB.4.0"
        .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"
        .Open
    End With
     
     sql = "SELECT * FROM [Dados$]"

    'monta a cláusula WHERE
    'Nome
    Call MontaClausulaWhere(txtcliente.Name, "Cliente", sqlWhere)
    Call MontaClausulaWhere(Cbomes.Name, "Mês", sqlWhere)
    Call MontaClausulaWhere(CboAno.Name, "Ano", sqlWhere)
    Call MontaClausulaWhere(Cbocias.Name, "Cia", sqlWhere)
    


    'faz a união da string SQL com a cláusula WHERE
    If sqlWhere <> vbNullString Then
        sql = sql & " WHERE " & sqlWhere
    End If

    'faz a união da string SQL com a cláusula ORDER BY
    If cboOrdenarPor.listindex <> -1 Then
        sqlOrderBy = " ORDER BY " & cboOrdenarPor.List(cboOrdenarPor.listindex, 0)
        'define a direção
        Select Case Cbodirecao.listindex
            Case Ascendente
                sqlOrderBy = sqlOrderBy & " ASC"
            Case Descendente
                sqlOrderBy = sqlOrderBy & " DESC"
        End Select
        'une a query order ao sql
        sql = sql & sqlOrderBy
    End If

    Set rst = New ADODB.Recordset
    With rst
        .ActiveConnection = conn
        .Open sql, conn, adOpenDynamic, _
              adLockBatchOptimistic
    End With

    'pega o número de registros para atribuí-lo ao listbox
    lstLista.ColumnCount = rst.Fields.Count

    'preenche o combobox com os nomes dos campos
    'persiste o índice
    Dim indiceTemp As Long
    indiceTemp = cboOrdenarPor.listindex
    cboOrdenarPor.Clear
    For Each campo In rst.Fields
        cboOrdenarPor.AddItem campo.Name
    Next
    'recupera o índice selecionado
    cboOrdenarPor.listindex = indiceTemp

    'coloca as linhas do RecordSet num Array, se houver linhas neste
    If Not rst.EOF And Not rst.BOF Then
        myArray = rst.GetRows
        'troca linhas por colunas no Array
        myArray = Array2DTranspose(myArray)
        'atribui o Array ao listbox
        lstLista.List = myArray
        'adiciona a linha de cabeçalho da coluna
        lstLista.AddItem , 0
        'preenche o cabeçalho
        For I = 0 To rst.Fields.Count - 1
            lstLista.List(0, I) = rst.Fields(I).Name
        Next I
        'seleciona o primeiro item da lista
        lstLista.listindex = 0
    Else
        lstLista.Clear
    End If
            ' Formata após o filtro
        For I = 1 To UBound(myArray) + 1
            lstLista.List(I, 7) = Right(Space(16) & Format(myArray(I - 1, 7), " #,0.00"), 16)
          '  LstLista.List(i, 8) = Right(Space(16) & Format(myArray(i - 1, 8), "R$ #,0.00"), 16) 'VALOR
        Next I

  
  

    'atualiza o label de mensagens
    If lstLista.ListCount <= 0 Then
        lblmensagens.Caption = lstLista.ListCount & " registros encontrados"
    Else
        lblmensagens.Caption = lstLista.ListCount - 1 & " registros encontrados"
    End If

    ' Fecha o conjunto de registros.
    Set rst = Nothing
    ' Fecha a conexão.
    conn.Close

TrataSaida:
    Exit Sub
TrataErro:
    Debug.Print Err.Description & vbNewLine & Err.Number & vbNewLine & Err.Source
    Resume TrataSaida
    
    


    
End Sub
 
Postado : 12/07/2018 12:38 pm
NERI S
(@neri-s)
Posts: 0
Estimable Member
Topic starter
 

Resolvido alterando o comando:

Microsoft.JET.OLEDB.4.0 por Microsoft.ACE.OLEDB.12.0

Fica o registro se alguém mais enfrentar o mesmo problema.

 
Postado : 12/07/2018 1:17 pm