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