Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Alterar Contagem pa...
 
Notifications
Clear all

Alterar Contagem para Soma Listview na Label

 
2024 - VBA & Macros
Post Recente por klarc28 6 anos atrás
4 Posts
3 Usuários
0 Reactions
1,125 Visualizações
RSS
 Edupm
(@edupm)
Posts: 0
New Member
Topic starter
 

Boa tarde!

No Label lblMensagens conta a quantidade de registros.

Pergunta

Como Somar a Coluna A do Listview nessa Label

segue anexo para alteração...

 
Postado : 15/06/2018 12:10 pm
 boobymcgee
(@boobymcgee)
Posts: 0
New Member
 

Assim

 
Postado : 15/06/2018 3:06 pm
 Edupm
(@edupm)
Posts: 0
New Member
Topic starter
 

até ai tudo bem o problema é que se vc usar o filtro do form esse label que vc fez a soma não atualiza, faz o teste ai...

 
Postado : 15/06/2018 5:06 pm
 klarc28
(@klarc28)
Posts: 0
New Member
 

Para somar os códigos:

'Modelo de Aplicativo de Cadastro em VBA no Microsoft Excel
'Autor: Tomás Vásquez
'http://www.tomasvasquez.com.br
'http://tomas.vasquez.blog.uol.com.br
'março de 2008

Option Explicit

'constantes para auxiliar na verificação do código
Private Const Ascendente As Byte = 0
Private Const Descendente As Byte = 1

Private Sub btnFiltrar_Click()
    Call PopulaListBox(txtNomeEmpresa.Text)
End Sub

Private Sub lblEndereco_Click()

End Sub

Private Sub frmFiltros_Click()

End Sub


Private Sub lblMensagens_Click()

End Sub

Private Sub lstLista_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    If lstLista.ListIndex > 0 Then
        Dim indiceRegistro As Long
        indiceRegistro = frmCadastro.ProcuraIndiceRegistroPodId(lstLista.List(lstLista.ListIndex, 0))
        If indiceRegistro <> -1 Then
            Call frmCadastro.CarregaRegistroPorIndice(indiceRegistro)
        End If
        Unload Me
    Else
        lblMensagens.Caption = "É preciso selecionar um item válido na lista"
    End If
End Sub

Private Sub txtEndereco_Change()

End Sub

Private Sub UserForm_Activate()

End Sub

Private Sub UserForm_Initialize()

   
   
    Call PopulaListBox(vbNullString)
    
     frmPesquisa.Show
End Sub

Private Sub PopulaListBox(ByVal NomeEmpresa 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 [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
    Dim indiceTemp As Long
    
    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
'
Dim j As Long

Dim soma As Long

soma = 0

For j = 1 To Me.lstLista.ListCount - 1
soma = soma + CLng(Me.lstLista.List(j, 0))
Next j

    lblMensagens.Caption = soma
    

    ' 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

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
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

Para contar os registros:

'Modelo de Aplicativo de Cadastro em VBA no Microsoft Excel
'Autor: Tomás Vásquez
'http://www.tomasvasquez.com.br
'http://tomas.vasquez.blog.uol.com.br
'março de 2008

Option Explicit

'constantes para auxiliar na verificação do código
Private Const Ascendente As Byte = 0
Private Const Descendente As Byte = 1

Private Sub btnFiltrar_Click()
    Call PopulaListBox(txtNomeEmpresa.Text)
End Sub

Private Sub lblEndereco_Click()

End Sub

Private Sub frmFiltros_Click()

End Sub


Private Sub lblMensagens_Click()

End Sub

Private Sub lstLista_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    If lstLista.ListIndex > 0 Then
        Dim indiceRegistro As Long
        indiceRegistro = frmCadastro.ProcuraIndiceRegistroPodId(lstLista.List(lstLista.ListIndex, 0))
        If indiceRegistro <> -1 Then
            Call frmCadastro.CarregaRegistroPorIndice(indiceRegistro)
        End If
        Unload Me
    Else
        lblMensagens.Caption = "É preciso selecionar um item válido na lista"
    End If
End Sub

Private Sub txtEndereco_Change()

End Sub

Private Sub UserForm_Activate()

End Sub

Private Sub UserForm_Initialize()

   
   
    Call PopulaListBox(vbNullString)
    
     frmPesquisa.Show
End Sub

Private Sub PopulaListBox(ByVal NomeEmpresa 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 [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
    Dim indiceTemp As Long
    
    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
'
Dim j As Long

Dim soma As Long

soma = 0

For j = 1 To Me.lstLista.ListCount - 1
soma = soma + 1
Next j

    lblMensagens.Caption = soma
    

    ' 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

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
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 : 17/06/2018 11:32 am
Forum Jump:
  Tópico Anterior
Próximo Tópico