Wagner agradeço pela resposta não fui claro na explicação.... Por exemplo:
No Textbox eu digito: a palavra carro. Então no Listview vai aparecer tudo referente a Carro que existe no cadastro, conforme abaixo.
teste 1
carro 2
pedra 3
carro 4
Então no label abaixo o Resultado será 02 palavras referente a carro encontrados e na soma 06.
Label " lblMensagens.Caption = 02 registros encontrados
Label " LabelSomaRegistros = 06
Se apagar a palavra carro do textbox então o resultado será:
Label " lblMensagens.Caption = 04 registros encontrados
Label " LabelSomaRegistros = 10
O Label lblMensagens está funcionando perfeitamente, só o Label " LabelSomaRegistros que não...
ele só mostra a soma total de todos os registros, mas o que preciso é ao digitar uma palavra ele dar a SOMA dos valores corresponde a palavra digitada no Textbox....
Segue o código
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)
Call MontaClausulaWhere(Me.Txt_PESQNOME.Name, "Nome", sqlWhere)
Call MontaClausulaWhere(Me.txtNomeCOMPANY.Name, "Empresa", sqlWhere)
Call MontaClausulaWhere(Me.Text_pesqdata.Name, "Data", sqlWhere)
Call MontaClausulaWhere(Me.Text_pesqmatricula.Name, "Registro", sqlWhere)
Call MontaClausulaWhere(Me.TextBoxCARGO.Name, "Cargo", 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
Dim SomaRegistros As Long
Dim UltimaLinha As Long
Dim k As Long
'Somar os registros
UltimaLinha = Sheets("registro").Cells(Cells.Rows.Count, 1).End(xlUp).Row
If UltimaLinha < 2 Then UltimaLinha = 2
For k = 2 To UltimaLinha
SomaRegistros = SomaRegistros + CLng(Range("h" & k).Value)
Next
Set conn1 = New ADODB.Connection
With conn1
.Provider = "Microsoft.JET.OLEDB.4.0"
.ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"
.Open
End With
'Atualiza o label da soma de registros
If SomaRegistros <> 0 Then
LabelSomaRegistros.Caption = "Soma dos Registros: " & SomaRegistros
End If
' Fecha o conjunto de registros.
Set rst1 = Nothing
' Fecha a conexão.
conn1.Close
' 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)
Call MontaClausulaWhere(Me.Txt_PESQNOME.Name, "NomeDaEmpresa", sqlWhere)
Call MontaClausulaWhere(Me.txtNomeCOMPANY.Name, "NomeDaEmpresa", sqlWhere)
Call MontaClausulaWhere(Me.Text_pesqdata.Name, "NomeDaEmpresa", sqlWhere)
Call MontaClausulaWhere(Me.Text_pesqmatricula.Name, "NomeDaEmpresa", sqlWhere)
Call MontaClausulaWhere(Me.TextBoxCARGO.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
Postado : 13/06/2018 2:43 pm