Listview parou de mostrar letras só está mostrando números

Edupm

(@edupm)

Posts: 44

Eminent Member

Topic starter

Pessoal o Listview parou de mostrar Letras só mostra números, tem algum código para ajustar não entendo muito mas parece ser um problema de compatibilidade sei lá....

alguém sugere algum procedimento pra eu testar aqui..... Me ajudem por favor....

Postado : 17/04/2018 2:43 pm

Wagner Morel

(@wagner-morel-vidal-nobre)

Posts: 0

Illustrious Member

Edupm,

Bom dia!

Anexe um pequeno exemplo aqui no fórum, compactado com .ZIP.

Desenvolvo pequenas soluções em VBA Excel a valores que variam entre R$ 50,00 a R$ 200,00. Se te interessar, entre no meu instagran (vba_excel_desenvolvimento)

Atenciosamente
Wagner Morel

Postado : 18/04/2018 5:02 am

Edupm

(@edupm)

Posts: 44

Eminent Member

Topic starter

Como não consigo postar a planilha aqui peço que analisem o código abaixo e me ajudem por favor....

'Cole as informações na célula A1 do excel

Código Registro Nome Empresa
1 1322 a 1322
2 1459 b 1459
3 839 c 839
4 0 g TOYOTA
5 0 h AUDI

-----------------------------------------------------------------------------------------------------------
'Cole o código abaixo no vba excel

Private TextoDigitado As String
Private Const Ascendente As Byte = 0
Private Const Descendente As Byte = 1

Dim BANCO As Database
Dim TABELA As Recordset




Private Sub btnFiltrar_Click()

Call PopulaListBox(txtNomeEmpresa.Text)

End Sub

Private Sub lstLista_Click()

End Sub

Private Sub txtNomeEmpresa_Change()

Me.txtNomeEmpresa = UCase(Me.txtNomeEmpresa.Text)

TextoDigitado = txtNomeEmpresa.Text
' Call PreencheLista
Call PopulaListBox(vbNullString)
End Sub


Private Sub PopulaListBox(ByVal NomeEmpresa As String)


Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

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 [REGISTRO$]"

'monta a cláusula WHERE
'NomeDaEmpresa
Call MontaClausulaWhere(txtNomeEmpresa.Name, "Objetivos", 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


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


'recupera o índice selecionado


'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

'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


Dim wis As Worksheet

Dim TextoCelula As String



Dim ws As Worksheet

Set ws = ThisWorkbook.Worksheets(1)
i = 1
lstLista.Clear
With ws
While .Cells(i, 1).Value <> Empty
TextoCelula = .Cells(i, 1).Value
If UCase(Left(TextoCelula, Len(TextoDigitado))) = UCase(TextoDigitado) Then
lstLista.AddItem .Cells(i, 1)
End If
i = i + 1
Wend


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 [Fornecedores$]"

'monta a cláusula WHERE
'NomeDaEmpresa
Call MontaClausulaWhere(txtNomeEmpresa.Name, "NomeDaEmpresa", 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


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


For Each campo In rst.Fields

Next
'recupera o índice selecionado


'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

'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


Exit Sub

Debug.Print Err.Description & vbNewLine & Err.Number & vbNewLine & Err.Source
Resume TrataSaida
End With


Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True



End Sub

Private Sub MontaClausulaWhere(ByVal NomeControle As String, ByVal NomeCampo As String, ByRef sqlWhere As String)
'NomeDoContato
If Trim(Me.Controls(NomeControle).Text) <> vbNullString Then
If sqlWhere <> vbNullString Then
sqlWhere = sqlWhere & " AND"
End If
sqlWhere = sqlWhere & " " & NomeCampo & " LIKE '%" & Trim(Me.Controls(NomeControle).Text) & "%'"
End If

'NomeDoContato
If Trim(Me.Controls(NomeControle).Text) <> vbNullString Then
If sqlWhereb <> vbNullString Then
sqlWhereb = sqlWhereb & " AND"
End If
sqlWhereb = sqlWhereb & " " & NomeCampos & " LIKE '%" & Trim(Me.Controls(NomeControle).Text) & "%'"
End If

End Sub

'Faz a transpasição de um array, transformando linhas em colunas
Private Function Array2DTranspose(avValues As Variant) As Variant
Dim lThisCol As Long, lThisRow As Long
Dim lUb2 As Long, lLb2 As Long
Dim lUb1 As Long, lLb1 As Long
Dim avTransposed As Variant

If IsArray(avValues) Then
On Error GoTo ErrFailed
lUb2 = UBound(avValues, 2)
lLb2 = LBound(avValues, 2)
lUb1 = UBound(avValues, 1)
lLb1 = LBound(avValues, 1)

ReDim avTransposed(lLb2 To lUb2, lLb1 To lUb1)
For lThisCol = lLb1 To lUb1
For lThisRow = lLb2 To lUb2
avTransposed(lThisRow, lThisCol) = avValues(lThisCol, lThisRow)
Next
Next
End If

Array2DTranspose = avTransposed
Exit Function

ErrFailed:
Debug.Print Err.Description
Debug.Assert False
Array2DTranspose = Empty
Exit Function
Resume



End Function

Postado : 18/04/2018 12:41 pm

Edupm

(@edupm)

Posts: 44

Eminent Member

Topic starter

É só importar pra dentro da planilha o VBA, vc vai ver que o campo EMPRESA só busca número, mas o texto não busca....... Me ajuda por favor

Como não consigo postar a planilha aqui peço que analisem o código abaixo e me ajudem por favor....

'Cole as informações na célula A1 do excel

Código Registro Nome Empresa
1 1322 a 1322
2 1459 b 1459
3 839 c 839
4 0 g TOYOTA
5 0 h AUDI

Private TextoDigitado As String
Private Const Ascendente As Byte = 0
Private Const Descendente As Byte = 1

Dim BANCO As Database
Dim TABELA As Recordset




Private Sub btnFiltrar_Click()

Call PopulaListBox(txtNomeEmpresa.Text)

End Sub

Private Sub lstLista_Click()

End Sub

Private Sub txtNomeEmpresa_Change()

Me.txtNomeEmpresa = UCase(Me.txtNomeEmpresa.Text)

TextoDigitado = txtNomeEmpresa.Text
' Call PreencheLista
Call PopulaListBox(vbNullString)
End Sub


Private Sub PopulaListBox(ByVal NomeEmpresa As String)


Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

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 [REGISTRO$]"

'monta a cláusula WHERE
'NomeDaEmpresa
Call MontaClausulaWhere(txtNomeEmpresa.Name, "Objetivos", 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


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


'recupera o índice selecionado


'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

'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


Dim wis As Worksheet

Dim TextoCelula As String



Dim ws As Worksheet

Set ws = ThisWorkbook.Worksheets(1)
i = 1
lstLista.Clear
With ws
While .Cells(i, 1).Value <> Empty
TextoCelula = .Cells(i, 1).Value
If UCase(Left(TextoCelula, Len(TextoDigitado))) = UCase(TextoDigitado) Then
lstLista.AddItem .Cells(i, 1)
End If
i = i + 1
Wend


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 [Fornecedores$]"

'monta a cláusula WHERE
'NomeDaEmpresa
Call MontaClausulaWhere(txtNomeEmpresa.Name, "NomeDaEmpresa", 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


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


For Each campo In rst.Fields

Next
'recupera o índice selecionado


'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

'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


Exit Sub

Debug.Print Err.Description & vbNewLine & Err.Number & vbNewLine & Err.Source
Resume TrataSaida
End With


Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True



End Sub

Private Sub MontaClausulaWhere(ByVal NomeControle As String, ByVal NomeCampo As String, ByRef sqlWhere As String)
'NomeDoContato
If Trim(Me.Controls(NomeControle).Text) <> vbNullString Then
If sqlWhere <> vbNullString Then
sqlWhere = sqlWhere & " AND"
End If
sqlWhere = sqlWhere & " " & NomeCampo & " LIKE '%" & Trim(Me.Controls(NomeControle).Text) & "%'"
End If

'NomeDoContato
If Trim(Me.Controls(NomeControle).Text) <> vbNullString Then
If sqlWhereb <> vbNullString Then
sqlWhereb = sqlWhereb & " AND"
End If
sqlWhereb = sqlWhereb & " " & NomeCampos & " LIKE '%" & Trim(Me.Controls(NomeControle).Text) & "%'"
End If

End Sub

'Faz a transpasição de um array, transformando linhas em colunas
Private Function Array2DTranspose(avValues As Variant) As Variant
Dim lThisCol As Long, lThisRow As Long
Dim lUb2 As Long, lLb2 As Long
Dim lUb1 As Long, lLb1 As Long
Dim avTransposed As Variant

If IsArray(avValues) Then
On Error GoTo ErrFailed
lUb2 = UBound(avValues, 2)
lLb2 = LBound(avValues, 2)
lUb1 = UBound(avValues, 1)
lLb1 = LBound(avValues, 1)

ReDim avTransposed(lLb2 To lUb2, lLb1 To lUb1)
For lThisCol = lLb1 To lUb1
For lThisRow = lLb2 To lUb2
avTransposed(lThisRow, lThisCol) = avValues(lThisCol, lThisRow)
Next
Next
End If

Array2DTranspose = avTransposed
Exit Function

ErrFailed:
Debug.Print Err.Description
Debug.Assert False
Array2DTranspose = Empty
Exit Function
Resume



End Function[/quote]

Postado : 19/04/2018 5:15 am

Wagner Morel

(@wagner-morel-vidal-nobre)

Posts: 0

Illustrious Member

Edupm,

Boa tarde!

Como estou meio sem tempo para analisar todo esse seu código e também como não foi possível você postar seu arquivo, fiz um pequeno arquivo com os dados que você passou e fiz um pequeno exemplo de popular os dados em um ListView. Veja que não há qualquer problema com o carregamento de letras ou números em qualquer coluna.

ATENÇÃO: Antes de executar, lembre-se que precisa adicionar a referência Microsoft Windows Common Controls 6.0 (SP6) ou superior.

Preencher ListView.zip

Desenvolvo pequenas soluções em VBA Excel a valores que variam entre R$ 50,00 a R$ 200,00. Se te interessar, entre no meu instagran (vba_excel_desenvolvimento)

Atenciosamente
Wagner Morel

Postado : 19/04/2018 11:18 am