Problema muito complicado ou talvez não ...

Question

Boa noite, amigos.

Deparo-me com um problema deveras complicado e que espero tenha solução.

Numa coluna contendo 1750 linhas de registo (Lastline=1751), preciso inserir na coluna "F" o nº de elementos que compõem os agregados familiares de todos eles. Isto para saber quantos agregados compõem a lista e nesse conjunto de agregados familiares, quantos têm 1, 2, 3, 4, 5 ou 6 elementos.

Pensei, por exemplo para uma família de 3 elementos fazer o seguinte:

Registar o nº 3 em todos eles e no final, fazer o nº 3 dividir-se por ele próprio o que daria 1 agregado o que no caso de uma contagem de 6 elementos, dividido por 3 daria 2 agregados.

A parte difícil...

Acontece que existem casos em que apenas 1 elemento faz parte da minha lista e os outros 2 fazem parte de outra lista e que obviamente não poderão ser considerados. Mas na minha contagem esse elemento deverá fazer somar mais um agregado familiar.

Então pensei em colocar uma condição em que se a divisão por 3 fosse diferente de um inteiro, então somaria ao inteiro resultante da divisão + 1, o que até certo ponto dava certo.

No entanto se acontecer que o próximo agregado tiver apenas dois elementos, vamos obter um número inteiro que na realidade não é real, pois deveríamos obter dois parciais e portanto uma soma de 2.

Tenho estado a usar este procedimento, só que não me resolve esta falha.

        If var = "3" Then
            .AddItem
            ListBox7.ColumnWidths = "140;80;120;30"
            .List(.ListCount - 1, 0) = var
                If dic(var) / 3 <> Int(dic(var) / 3) Then
                    dic(var) = Int(dic(var) / 3) + 1
                    .List(.ListCount - 1, 1) = dic(var)
                    .List(.ListCount - 1, 2) = Format(Int(dic(var) * 100) / ttvar, "0.00") '& CheckBox2.Caption
                Else
                    .List(.ListCount - 1, 1) = dic(var) / 3
                    .List(.ListCount - 1, 2) = Format((Int(dic(var) / 3) * 100) / ttvar, "0.00") '& CheckBox2.Caption
                End If
            .List(.ListCount - 1, 3) = " %"
        End If

Haverá solução para isto?

Antecipadamente agradecido

Cumprimentos

M_A_L

---

M_A_L

Answer 1

Não entendi muito bem o que pretende, mas creio que tenha algo que facilite seus cálculos.

Para saber se uma determinada divisão lhe dá um número inteiro ou não, utilize a função Mod. Mod retorna o resto de uma divisão.

Por exemplo: 5 Mod 3 dá 2, pois é o resto de 5 dividido por 2.

Então, para fazer os testes de divisão, você poderia fazer algo como If (x Mod 3) > 0 Then...

Você pode também criar cenários para verificar quanto o resto deu:

  Select Case x Mod 3
    Case 0
      Debug.Print "Divisão inteira."
    Case 1
      Debug.Print "Resto um."
    Case 2
      Debug.Print "Resto 2."
  End Select

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 2

Obrigado, Felipe pela sua resposta.

No entanto, não é isto que pretendo.

Imagine um agregado familiar com 3 pessoas. Duas fazem parte da minha lista e a outra não. Nas duas pessoas que fazem parte da minha lista tenho que colocar a informação como fazendo parte de um Agreg. Fam. de 3 pessoas.

Utilizando a divisão conforme o post, para um caso dava certo, mas se num 2º Agreg. Fam., apenas 1 pessoa fizesse parte da minha lista, os cálculos deixavam de corresponder, pois iria somar os dois restos e fazer um.

A forma que hoje encontrei, altera a estrutura de dados a introduzir, mas não falha, desta forma e entrada de dados serás feita assim:

AG. FAM com 3 elementos da minha lista, os elementos serão classificados com 3.3 que é o mesmo que 3 de 3.

AG. FAM. com 3 elementos, mas só 1 da minha lista será classificado como "3.1", 1 de 3.

... e assim sucessivamente, 5.5 ou 5.2 conforme todos constem na minha lista ou constem apenas dois.

Depois criei Cases para cada variável que em conjunto com uma sua rotina que me facultou antes, fazendo dividir os valores das Case pelo nº de elementos constantes na lista (nº à direita da vírgula), me dá o valor que preciso.

Penso que a instrução "Mod", neste caso não funcionará pois ela iria fazer as contas para cada elemento, estou certo? Nunca utilizei a instrução, mas de acordo com a sua explicação parece-me isso.

Realmente o pretendido e em VBA muito grosseiro, pretende-se que em cada variável "5.5" contada 5 vezes, isso corresponde a um agregado familiar com 5 pessoas.

Não consigo dar melhor explicação, mas se olhar o código que implementei e que posto a seguir, sei que aí vai entender o que pretendo. Afinal o VBA é a sua segunda língua (apenas como força de expressão).

Como sabe pouco sei de VBA, por isso o código está provavelmente cheio de arestas que precisarão de ser limadas e é claro que todos os melhoramentos que puder implementar, são bem vindos e agradecidos.

    Const cstrCol As String = "F"

Dim ttvar As Integer
Dim RowTFAMIL, LastTFAMIL As Long
Dim wks As Excel.Worksheet
Dim dic As Object ' Scripting.Dictionary
Dim var As Variant

Dim str, astr() As String
  
Set dic = CreateObject("Scripting.Dictionary")
Set wks = ThisWorkbook.Worksheets("REGISTOS")

With wks
  LastTFAMIL = .Cells(.Rows.Count, cstrCol).End(xlUp).Row
    For RowTFAMIL = 2 To LastTFAMIL
      str = .Cells(RowTFAMIL, cstrCol).Value
        If str <> "" Then
          If VBA.Len(str) > 0 Then
            str = VBA.Mid(str, 1) ' O "1" define o carater da variável onde começa
            astr = VBA.Split(str, "")
              For Each var In astr
                str = VBA.CStr(var)
                  If dic.Exists(str) Then
                    dic(str) = dic(str) + 1
                  Else
                    dic.Add str, 1
                  End If
                ttvar = ttvar + 1
              Next var
            End If
          End If
    Next RowTFAMIL
End With
  
Label197.Caption = LastTFAMIL - 1

Dim AF1 As Variant, AF21 As Variant, AF22 As Variant, AF31 As Variant, AF As Variant
Dim AgFcons
Dim AgF, EscalaoAgF

AgF = Sheets("REGISTOS").Cells(Cells.Rows.Count, 6).End(xlUp).Row
        
For AgFcons = 2 To AgF
    If Range("REGISTOS!F" & AgFcons).Value <> "" Then
            
'============================= lista de elementos das famílias ===================
    EscalaoAgF = Sheets("REGISTOS").Range("F" & AgFcons)
                
        Select Case EscalaoAgF
            Case "--": AF = AF + 1
            Case 1: AF1 = AF1 + 1
            Case 2.1: AF21 = AF21 + 1
            Case 2.2: AF22 = AF22 + 1
            Case 3.1: AF31 = AF31 + 1
            Case 3.2: AF32 = AF32 + 1
            Case 3.3: AF33 = AF33 + 1
            Case 4.1: AF41 = AF41 + 1
            Case 4.2: AF42 = AF42 + 1
            Case 4.3: AF43 = AF43 + 1
            Case 4.4: AF44 = AF44 + 1
            Case 5.1: AF51 = AF51 + 1
            Case 5.2: AF52 = AF52 + 1
            Case 5.3: AF53 = AF53 + 1
            Case 5.4: AF54 = AF54 + 1
            Case 5.5: AF55 = AF55 + 1
            Case 6.1: AF61 = AF61 + 1
            Case 6.2: AF62 = AF62 + 1
            Case 6.3: AF63 = AF63 + 1
            Case 6.4: AF64 = AF64 + 1
            Case 6.5: AF65 = AF65 + 1
            Case 6.6: AF66 = AF66 + 1
            Case 7.1: AF71 = AF71 + 1
            Case 7.2: AF72 = AF72 + 1
            Case 7.3: AF73 = AF73 + 1
            Case 7.4: AF74 = AF74 + 1
            Case 7.5: AF75 = AF75 + 1
            Case 7.6: AF76 = AF76 + 1
            Case 7.7: AF77 = AF77 + 1
            Case 7.8: AF78 = AF78 + 1
        End Select
    End If
Next AgFcons

  With Me.ListBox7
    .ColumnCount = 4
    ListBox7.ColumnWidths = "140;80;120;30"
    
    .AddItem
    .List(.ListCount - 1, 0) = "1"
    .List(.ListCount - 1, 1) = AF1
    .List(.ListCount - 1, 2) = Format((AF1 * 100) / ttvar, "0.00")
    .List(.ListCount - 1, 3) = " %"
    
    .AddItem
    .List(.ListCount - 1, 0) = "2"
    .List(.ListCount - 1, 1) = AF21 / 1 + AF22 / 2
    .List(.ListCount - 1, 2) = Format((((AF21 / 1) + (AF22 / 2)) * 100) / ttvar, "0.00")
    .List(.ListCount - 1, 3) = " %"
    
    .AddItem
    .List(.ListCount - 1, 0) = "3"
    .List(.ListCount - 1, 1) = AF31 / 1 + AF32 / 2 + AF33 / 3
    .List(.ListCount - 1, 2) = Format((((AF31 / 1) + (AF32 / 2) + (AF33 / 3)) * 100) / ttvar, "0.00")
    .List(.ListCount - 1, 3) = " %"
    
    .AddItem
    .List(.ListCount - 1, 0) = "4"
    .List(.ListCount - 1, 1) = AF41 / 1 + AF42 / 2 + AF43 / 3 + AF44 / 4
    .List(.ListCount - 1, 2) = Format((((AF41 / 1) + (AF42 / 2) + (AF43 / 3) + (AF44 / 4)) * 100) / ttvar, "0.00")
    .List(.ListCount - 1, 3) = " %"
    
    .AddItem
    .List(.ListCount - 1, 0) = "5"
    .List(.ListCount - 1, 1) = AF51 / 1 + AF52 / 2 + AF53 / 3 + AF54 / 4 + AF55 / 5
    .List(.ListCount - 1, 2) = Format((((AF51 / 1) + (AF52 / 2) + (AF53 / 3) + (AF54 / 4) + (AF55 / 5)) * 100) / ttvar, "0.00")
    .List(.ListCount - 1, 3) = " %"
    
    .AddItem
    .List(.ListCount - 1, 0) = "6"
    .List(.ListCount - 1, 1) = AF61 / 1 + AF62 / 2 + AF63 / 3 + AF64 / 4 + AF65 / 5 + AF66 / 6
    .List(.ListCount - 1, 2) = Format((((AF61 / 1) + (AF62 / 2) + (AF63 / 3) + (AF64 / 4) + _
                                (AF65 / 5) + (AF66 / 6)) * 100) / ttvar, "0.00")
    .List(.ListCount - 1, 3) = " %"
    
    .AddItem
    .List(.ListCount - 1, 0) = "> = 7"
    .List(.ListCount - 1, 1) = AF71 / 1 + AF72 / 2 + AF73 / 3 + AF74 / 4 + AF75 / 5 + AF76 / 6 + AF77 / 7 + AF78 / 8
    .List(.ListCount - 1, 2) = Format((((AF71 / 1) + (AF72 / 2) + (AF73 / 3) + (AF74 / 4) + _
                        (AF75 / 5) + (AF76 / 6) + (AF77 / 7) + (AF78 / 8)) * 100) / ttvar, "0.00")
    .List(.ListCount - 1, 3) = " %"
        
    .AddItem
    .List(.ListCount - 1, 0) = "--"
    .List(.ListCount - 1, 1) = AF
    .List(.ListCount - 1, 2) = Format((AF * 100) / ttvar, "0.00")
    .List(.ListCount - 1, 3) = " %"

    
  End With

Esquisito é que no código a maior parte das variáveis "AF(nº)" não estão declaradas e o código rola da mesma forma e sem erros.

Cumprimentos

M_A_L

---

M_A_L

Answer 3

Se entendi bem, experimente executar essa rotina:

Private Sub pMain()
  Const csCol As String = "F"
  
  Dim dic As Object 'Scripting.Dictionary
  Dim lCount As Long
  Dim lDivisor As Long
  Dim lLast As Long
  Dim lRow As Long
  Dim lTotal As Long
  Dim oSheet As Excel.Worksheet
  Dim s As String
  Dim v As Variant
  
  Set oSheet = ThisWorkbook.Worksheets("REGISTOS")
  Set dic = CreateObject("Scripting.Dictionary")
  
  With oSheet
    lLast = .Cells(.Rows.Count, csCol).End(xlUp).Row
    
    'Verifica quais tipos de códigos de agregamentos
    'familiares existem e armazena quantidade dos mesmos:
    For lRow = 2 To lLast
      s = .Cells(lRow, csCol)
      If Len(Trim(s)) > 0 Then
        If dic.Exists(s) Then
          dic(s) = dic(s) + 1
        Else
          dic.Add s, 1
        End If
      End If
    Next lRow
  
    'Contabiliza as agregações:
    For Each v In dic.Keys
      lCount = dic(v)
      lDivisor = Split(v, ".")(1)
      lTotal = lTotal + WorksheetFunction.RoundUp(lCount / lDivisor, 0)
    Next v
  End With
  
  Debug.Print "Total de " & lTotal & " agregados familiares."
End Sub

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 4

Boa noite Felipe.

Experimentei a rotina que gentilmente cedeu e dá-me este erro no ciclo For --- Next, linha "IDivisor=Split(v,".")(1)

O que poderá ser?

Substituí o código que tinha pelo que disponibilizou.

Cumprimentos

M_A_L

Answer 5

Note que a primeira letra da variável é um L e não um I. Faço isso porque gosto de saber qual é o tipo de dado da variável (L de Long, nesse caso) só de bater o olho nela.

Bom, minha premissa ao sugerir esse código é que todos os registros da coluna F são da forma #.#, em que # é um número e um ponto final obrigatoriamente deve existir.

Analisando melhor o seu código, vi que você previu um caso de agregamento em que o . não existe, que é o caso 1. Por gentileza, substitua nessa coluna todos os registros 1 por 1.1 e tente novamente.

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 6

Boa noite, Felipe.

Segui a sua sugestão. No post aconteceu um erro de digitação mas no código, efetivamente é um "L" minúsculo que substituí agora por maiúsculo até porque deduzi que fizesse referência ao tipo de variável, pois vejo muito esse tipo de codificação em quase todos os seus códigos bem como em alguns sites e blogues que tratam o VBA com níveis mais elevados.

Substituí o nº 1 por "1.1" e reparei que na folha algumas células me informavam que estavam formatadas como texto e corrigi tudo. Utilizo o "." colocado no teclado numérico e ao inserir valores pelo userform estes ficam gravados na folha no formato "#,#", isto é o ponto é apresentado como vírgula.

Na sua rotina tentei substituir o Ponto Final que causa o split pela Vírgula no entanto, sem sucesso.

O erro permanece e na mesma linha.

O código que neste momento está associado ao Botão é o seguinte:

Private Sub CommandButton17_Click() '===========Nº AGREGADOS FAMILIARES

ListBox7.Clear
ListBox7.Visible = True: ListBox6.Visible = False: ListBox8.Visible = False
ListBox7.ForeColor = -2147483630
Label205.Visible = True: Label208.Visible = True
Label205.Caption = "Nº DE ELEMENTOS"
Label206.Visible = True: Label207.Visible = True
CheckBox24.Locked = True
CheckBox26.Locked = True
CheckBox25.Locked = False

  Const csCol As String = "F"
  
  Dim dic As Object 'Scripting.Dictionary
  Dim LCount As Long
  Dim LDivisor As Long
  Dim LLast As Long
  Dim LRow As Long
  Dim LTotal As Long
  Dim oSheet As Excel.Worksheet
  Dim s As String
  Dim v As Variant
  
  Set oSheet = ThisWorkbook.Worksheets("REGISTOS")
  Set dic = CreateObject("Scripting.Dictionary")
  
  With oSheet
    LLast = .Cells(.Rows.Count, csCol).End(xlUp).Row
    
    'Verifica quais tipos de códigos de agregamentos
    'familiares existem e armazena quantidade dos mesmos:
    For LRow = 2 To LLast
      s = .Cells(LRow, csCol)
      If Len(Trim(s)) > 0 Then
        If dic.Exists(s) Then
          dic(s) = dic(s) + 1
        Else
          dic.Add s, 1
        End If
      End If
    Next LRow
  
    'Contabiliza as agregações:
    For Each v In dic.Keys
      LCount = dic(v)
      LDivisor = Split(dic(v), ".")(1)
      LTotal = LTotal + WorksheetFunction.RoundUp(LCount / LDivisor, 0)
    Next v
  End With
  
  Debug.Print "Total de " & LTotal & " agregados familiares."

  With Me.ListBox7
    .ColumnCount = 4
    ListBox7.ColumnWidths = "140;80;120;30"
  End With
End Sub

A Listbox ainda não tem ainda valores atribuídos e está apenas definida, mas é uma situação intencional.

No entanto há células que em vez de números contêm "--". Tentei então alterar a condição imposta no seu código colocando-a desta forma:

      If Len(Trim(s)) > 0 Or s <> "--" Then

O erro mantém-se, no entanto deixa de dar erro se colocar :

      If Len(Trim(s)) = 1 Then

Mas não apresenta qualquer resultado já que pelo que me parece não está a considerar os valores numéricos.

O Debug diz que que:

LRow=1752

LLast=1751

s="--"

csCol="F"

dic(s)=1420 ---- nº de variáveis iguais a "--"

v="--"

Portanto a rotina está a considerar apenas as células preenchidas com "--".

São as informações possíveis que lhe consigo dar depois de várias tentativas de alteração do código.

Cumprimentos

M_A_L

---

M_A_L

Answer 7

Experimente substituir a linha:

      If Len(Trim(s)) > 0 Then

por:

      If s Like "#.#" Then

(ou por #,# se for o caso)

Se mesmo assim não funcionar, favor disponibilizar a planilha REGISTOS para eu fazer os testes nos seus dados.

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 8

Boa noite Felipe.

Substituí a linha de código que mencionou e tentei com o ponto e com a vírgula, assim como outras alterações.

Nada resolveu e ou me dava o mesmo erro na mesma linha ou não apresentava nada mas também não dava erro.

Disponibilizei a folha "REGISTOS" enviando para o seu e-mail e peço desculpa por o ter feito sem autorização.

Continua a presentar-me o valor de "s" como sendo "--".

Obrigado pela sua dedicação e apoio.

Cumprimentos

M_A_L

---

M_A_L

Answer 9

Este código gerou 100 agregados familiares para mim:

Private Sub pMain()
  Const csCol As String = "F"
  
  Dim dic As Object 'Scripting.Dictionary
  Dim lCount As Long
  Dim lDivisor As Long
  Dim lLast As Long
  Dim lRow As Long
  Dim lTotal As Long
  Dim oSheet As Excel.Worksheet
  Dim s As String
  Dim v As Variant
  
  'Set oSheet = ThisWorkbook.Worksheets("REGISTOS")
  Set oSheet = ThisWorkbook.Worksheets("FOLHA1")
  Set dic = CreateObject("Scripting.Dictionary")
  
  With oSheet
    lLast = .Cells(.Rows.Count, csCol).End(xlUp).Row
    
    'Verifica quais tipos de códigos de agregamentos
    'familiares existem e armazena quantidade dos mesmos:
    For lRow = 2 To lLast
      s = .Cells(lRow, csCol)
      If s Like "#,#" Then
        If dic.Exists(s) Then
          dic(s) = dic(s) + 1
        Else
          dic.Add s, 1
        End If
      End If
    Next lRow
  
    'Contabiliza as agregações:
    For Each v In dic.Keys
      lCount = dic(v)
      lDivisor = Split(v, ",")(1)
      lTotal = lTotal + WorksheetFunction.RoundUp(lCount / lDivisor, 0)
    Next v
  End With
  
  Debug.Print "Total de " & lTotal & " agregados familiares."
End Sub

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 10

Boa tarde, Felipe.

Depois das correções conforme o seu código, apresenta efetivamente o resultado de 100.

Antes, quando o informei de uma situação em que não dava erro mas também não apresentava resultados, o código não tinha nada para os exibir. Atribuindo o "lTotal" a uma label, os ditos 100 aparecem. Agora vou tentar jogar com as variáveis e fazer aparecer os resultados como preciso e de acordo com a figura.

Esta é a estrutura que pretendo nos resultados que me são fornecidos com a rotina que postei inicialmente, pois só assim poderei elaborar o gráfico.

Penso que terei que colocar vários "If" no ciclo "For Each v", correto?

Vou por mãos à obra e ver se consigo os meus resultados manobrando a sua rotina.

Os meus agradecimentos.

Cumprimentos

M_A_L

---

M_A_L