[Resolvido]Encontrar conjunto de Números

Boa tarde a todos...

Uso este código criado pelo Dilson para um membro do fórum neste link

maximoaccess.com/t19563-resolvidoloop-quantidade-de-registros-especificos-entre-campos#144662

Funciona corretamento para o objetivo.

Estou tentando adaptar para que a Variável Encontrar, encontre um conjunto de números mas não obtive sucesso

Ex: Se meu campo Me!ConjNum contém apenas um número, ele percorre corretamente toda a tabela Resultados e me traz o número de ocorrências.

Preciso que se meu campo Me!ConjNum for um conjunto de números Ex:(5,9,11), ele faça o mesmo procedimento e só registre uma ocorrência se na tabela Resultados exista este conjunto, isto é só contar uma ocorrência se existir os 3 elementos

Nota: Na tabela resultados sempre vai existir 6 números e o meu campo Me!ConjNum pode variar de 1 a 6 números

Agradeço toda a ajuda

Abraços

Código:

Dim Rs As DAO.Recordset
Dim i As Integer
Dim Encontrar As Integer
Dim Encontrado As Long
Set Rs = CurrentDb.OpenRecordset("tblResultados")
Encontrar = Me!ConjNum
Encontrado = 0
For i = 1 To 6
Rs.MoveLast
Rs.MoveFirst
Do While Not Rs.EOF
  If Rs(("d" & i)) = Encontrar Then
        Encontrado = Encontrado + 1
  End If
Rs.MoveNext
Loop
Next i
Rs.Close
If Encontrado > 1 Then
MsgBox "Encontrado " _
      & Encontrado & " ocorrências."
Else
MsgBox "Encontrado " _
      & Encontrado & " ocorrências."
End If
End Sub

Boa tarde,
Não entendi bem como tem a tabela
Disponibilize bd com dados significativos

Olá Alexandre Neves

Obrigado pelo interesse em ajudar.

No exemplo anexo se você digitar qualquer número entre 1 e 60 no campo Me!ConjNum e clicar no botão, ele vai contar em todos os registros da tabela resultados a quantidade de vezes que ele existe.

O que preciso e digitar até 6 números diferentes separados por virgula ou qualquer outro delimitador e contar na tabela resultados quantas vezes este conjunto de números existe

Ex:( 5,9,11) vai existir 4 vezes conforme abaixo

Concurso Data
1016  25/10/2008 5 9 11 20 25 60
1077  27/05/2009 5 6 9 11 18 37
1262  02/03/2011 5 7 8 9 11 39
1276  20/04/2011 5 9 11 22 36 40

Abraços


Desculpe, faltou o arquivo

Já editei

Todo o código para o módulo

Código:

Option Compare Database
Option Explicit

Function NumerosCoincidentes(n1 As String, n2 As String, n3 As String, n4 As String, n5 As String, n6 As String, x1 As String, x2 As String, x3 As String, x4 As String, x5 As String, x6 As String) As Integer
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '  código criado por Alexandre Neves, do Fórum MaximoAccess  '
    '    utilize o código livremente mas mantenha os créditos    '
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim n1Coincidente As Boolean, n2Coincidente As Boolean, n3Coincidente As Boolean, n4Coincidente As Boolean, n5Coincidente As Boolean, n6Coincidente As Boolean
    If n1 = "" Then
        n1Coincidente = True
    Else
        If n1 = x1 Or n1 = x2 Or n1 = x3 Or n1 = x4 Or n1 = x5 Or n1 = x6 Then n1Coincidente = True
    End If
   
    If n2 = "" Then
        n2Coincidente = True
    Else
        If n2 = x1 Or n2 = x2 Or n2 = x3 Or n2 = x4 Or n2 = x5 Or n2 = x6 Then n2Coincidente = True
    End If
   
    If n3 = "" Then
        n3Coincidente = True
    Else
        If n3 = x1 Or n3 = x2 Or n3 = x3 Or n3 = x4 Or n3 = x5 Or n3 = x6 Then n3Coincidente = True
    End If
   
    If n4 = "" Then
        n4Coincidente = True
    Else
        If n4 = x1 Or n4 = x2 Or n4 = x3 Or n4 = x4 Or n4 = x5 Or n4 = x6 Then n4Coincidente = True
    End If
   
    If n5 = "" Then
        n5Coincidente = True
    Else
        If n5 = x1 Or n5 = x2 Or n5 = x3 Or n5 = x4 Or n5 = x5 Or n5 = x6 Then n5Coincidente = True
    End If
   
    If n6 = "" Then
        n6Coincidente = True
    Else
        If n6 = x1 Or n6 = x2 Or n6 = x3 Or n6 = x4 Or n6 = x5 Or n6 = x6 Then n6Coincidente = True
    End If
   
    If n1Coincidente And n2Coincidente And n3Coincidente And n4Coincidente And n5Coincidente And n6Coincidente Then NumerosCoincidentes = 1
End Function

Private Sub BtnContaComb_Click()
    Dim Rs As DAO.Recordset, I As Integer, Coincidentes As Integer
    Dim Texto As String, n1 As String, n2 As String, n3 As String, n4 As String, n5 As String, n6 As String
   
    Texto = Replace(Me!ConjNum, " ", "")
    Do
        If Texto = "" Then Exit Do
        If n1 = "" Then
            If InStr(1, Texto, ",") = 0 Then
                n1 = Texto
                Texto = ""
            Else
                n1 = Mid(Texto, 1, InStr(1, Texto, ",") - 1)
                Texto = Mid(Texto, Len(n1) + 2)
            End If
        ElseIf n2 = "" Then
            If InStr(1, Texto, ",") = 0 Then
                n2 = Texto
                Texto = ""
            Else
                n2 = Mid(Texto, 1, InStr(1, Texto, ",") - 1)
                Texto = Mid(Texto, Len(n2) + 2)
            End If
        ElseIf n3 = "" Then
            If InStr(1, Texto, ",") = 0 Then
                n3 = Texto
                Texto = ""
            Else
                n3 = Mid(Texto, 1, InStr(1, Texto, ",") - 1)
                Texto = Mid(Texto, Len(n3) + 2)
            End If
        ElseIf n4 = "" Then
            If InStr(1, Texto, ",") = 0 Then
                n4 = Texto
                Texto = ""
            Else
                n4 = Mid(Texto, 1, InStr(1, Texto, ",") - 1)
                Texto = Mid(Texto, Len(n4) + 2)
            End If
        ElseIf n5 = "" Then
            If InStr(1, Texto, ",") = 0 Then
                n5 = Texto
                Texto = ""
            Else
                n5 = Mid(Texto, 1, InStr(1, Texto, ",") - 1)
                Texto = Mid(Texto, Len(n5) + 2)
            End If
        Else
            n6 = Texto
            Texto = ""
        End If
    Loop
   
    Set Rs = CurrentDb.OpenRecordset("tblResultados")
   
    Do While Not Rs.EOF
        Coincidentes = Coincidentes + NumerosCoincidentes(n1, n2, n3, n4, n5, n6, Rs("dezena1"), Rs("dezena2"), Rs("dezena3"), Rs("dezena4"), Rs("dezena5"), Rs("dezena6"))
        Rs.MoveNext
    Loop
    Me.Ocorrencias = Coincidentes
    Rs.Close
    If Coincidentes = 0 Then
        MsgBox "Não foram encontradas ocorrências."
    ElseIf Coincidentes = 1 Then
        MsgBox "Encontrada 1 ocorrência."
    Else
        MsgBox "Encontradas " & Coincidentes & " ocorrências."
    End If
End Sub

Private Sub btnFechar_Click()
DoCmd.Close
End Sub


Olá Alexandre Neves

Mais uma vez agradeço a sua ajuda e te digo que o seu código funcionou na perfeição, mas preciso fazer uma alteração.

como as combinações possíveis é gerada em um subformulário do tipo contínuo,  como posso adaptar seu código para executar o resultado da Ocorrência em cada linha do subformulário?

Em cada linha do sub é uma combinação diferente, mas sempre com a mesma quantidade de elementos. Deixei uma coluna com os resultados que devem acontecer.

Eu tentei algumas alterações, mas sem exito

Segue o anexo modificado

Abraços

Olá a todos

Resolvido alterando conforme abaixo

Código:

Option Compare Database
Option Explicit

Function NumerosCoincidentes(n1 As String, n2 As String, n3 As String, n4 As String, n5 As String, n6 As String, x1 As String, x2 As String, x3 As String, x4 As String, x5 As String, x6 As String) As Integer
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '   código criado por Alexandre Neves, do Fórum MaximoAccess   '
    '     utilize o código livremente mas mantenha os créditos     '
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim n1Coincidente As Boolean, n2Coincidente As Boolean, n3Coincidente As Boolean, n4Coincidente As Boolean, n5Coincidente As Boolean, n6Coincidente As Boolean
    If n1 = "" Then
        n1Coincidente = True
    Else
        If n1 = x1 Or n1 = x2 Or n1 = x3 Or n1 = x4 Or n1 = x5 Or n1 = x6 Then n1Coincidente = True
    End If
    
    If n2 = "" Then
        n2Coincidente = True
    Else
        If n2 = x1 Or n2 = x2 Or n2 = x3 Or n2 = x4 Or n2 = x5 Or n2 = x6 Then n2Coincidente = True
    End If
    
    If n3 = "" Then
        n3Coincidente = True
    Else
        If n3 = x1 Or n3 = x2 Or n3 = x3 Or n3 = x4 Or n3 = x5 Or n3 = x6 Then n3Coincidente = True
    End If
    
    If n4 = "" Then
        n4Coincidente = True
    Else
        If n4 = x1 Or n4 = x2 Or n4 = x3 Or n4 = x4 Or n4 = x5 Or n4 = x6 Then n4Coincidente = True
    End If
    
    If n5 = "" Then
        n5Coincidente = True
    Else
        If n5 = x1 Or n5 = x2 Or n5 = x3 Or n5 = x4 Or n5 = x5 Or n5 = x6 Then n5Coincidente = True
    End If
    
    If n6 = "" Then
        n6Coincidente = True
    Else
        If n6 = x1 Or n6 = x2 Or n6 = x3 Or n6 = x4 Or n6 = x5 Or n6 = x6 Then n6Coincidente = True
    End If
    
    If n1Coincidente And n2Coincidente And n3Coincidente And n4Coincidente And n5Coincidente And n6Coincidente Then NumerosCoincidentes = 1
End Function

Private Function ContaComb()

Dim Rs As DAO.Recordset, I As Integer, Coincidentes As Integer
    Dim Texto As String, n1 As String, n2 As String, n3 As String, n4 As String, n5 As String, n6 As String
    
    Texto = Replace(Replace(Me!frmCombinacoesGeradasSubForm!ConjNum, " ", ""), "-", ",")
    
    Do
        If Texto = "" Then Exit Do
        If n1 = "" Then
            If InStr(1, Texto, ",") = 0 Then
                n1 = Texto
                Texto = ""
            Else
                n1 = Mid(Texto, 1, InStr(1, Texto, ",") - 1)
                Texto = Mid(Texto, Len(n1) + 2)
            End If
        ElseIf n2 = "" Then
            If InStr(1, Texto, ",") = 0 Then
                n2 = Texto
                Texto = ""
            Else
                n2 = Mid(Texto, 1, InStr(1, Texto, ",") - 1)
                Texto = Mid(Texto, Len(n2) + 2)
            End If
        ElseIf n3 = "" Then
            If InStr(1, Texto, ",") = 0 Then
                n3 = Texto
                Texto = ""
            Else
                n3 = Mid(Texto, 1, InStr(1, Texto, ",") - 1)
                Texto = Mid(Texto, Len(n3) + 2)
            End If
        ElseIf n4 = "" Then
            If InStr(1, Texto, ",") = 0 Then
                n4 = Texto
                Texto = ""
            Else
                n4 = Mid(Texto, 1, InStr(1, Texto, ",") - 1)
                Texto = Mid(Texto, Len(n4) + 2)
            End If
        ElseIf n5 = "" Then
            If InStr(1, Texto, ",") = 0 Then
                n5 = Texto
                Texto = ""
            Else
                n5 = Mid(Texto, 1, InStr(1, Texto, ",") - 1)
                Texto = Mid(Texto, Len(n5) + 2)
            End If
        Else
            n6 = Texto
            Texto = ""
        End If
    Loop
    
    Set Rs = CurrentDb.OpenRecordset("tblResultados")
    
    Do While Not Rs.EOF
        Coincidentes = Coincidentes + NumerosCoincidentes(n1, n2, n3, n4, n5, n6, Rs("dezena1"), Rs("dezena2"), Rs("dezena3"), Rs("dezena4"), Rs("dezena5"), Rs("dezena6"))
        Rs.MoveNext
    Loop
    Me!frmCombinacoesGeradasSubForm!Ocorrencias = Coincidentes
    Rs.Close
'    If Coincidentes = 0 Then
'        MsgBox "Não foram encontradas ocorrências."
'    ElseIf Coincidentes = 1 Then
'        MsgBox "Encontrada 1 ocorrência."
'    Else
'        MsgBox "Encontradas " & Coincidentes & " ocorrências."
'    End If
    Coincidentes = 0
End Function


No evento ao clicar do botão

Código:

Private Sub BtnContaComb_Click()
   Dim rst As Recordset
   
   Set rst = frmCombinacoesGeradasSubForm.Form.Recordset
   rst.MoveFirst

   Do While Not rst.EOF
     
   Call ContaComb
   rst.MoveNext
   Loop
End Sub

Obrigado a todos e em especial ao Alexandre Neves pela criação do código


Abraços