2

Preciso pegar um vetor em vba com N elementos quaisquer e realizar a combinação de tais elementos. A idéia e ter uma função que receba 2 argumentos. O vetor com os elementos a serem combinados e o tipo de combinação. 3x3, 4x4 , etc.

Caso essa ideia seja muito complicada, pois acho que deverá ser utilizado recursão poderia ser um algoritmo que realize esta tarefa por iteração. Neste caso elementos combinados 3x3.

O vetor que era o retorno da função possuirá os elementos agrupados e ao pegar os elementos agrupados eu terei a combinação desejada.

Ex: Este vetor será inserido na função, mas pode ser com quantos elementos desejar. Este é só um exemplo.

Array_Items(1)=1
Array_Items(2)=2
Array_Items(3)=3
Array_Items(4)=4

Resultado da combinação 3x3 neste vetor abaixo. Se eu pegar esse vetor de 3 em 3 elementos cada iteração me dá uma combinação. Ou seja a primeira combinação é 1,2,3; a segunda 1,2,4; a terceira 1,3,4, etc. Até o fim. A função deve trabalhar para qualquer tamanho de vetor que entrar para gerar a saída 3 a 3. (È claro sem estourar o limite do vba, mas isso é outra história). Pra combinação não importa a ordem. São únicas. O vetor que entrará como argumento da função nunca terá elementos repetidos. Ele vai ter consistência de dados antes.

Comb_array(1)=1
Comb_array(2)=2
Comb_array(3)=3
Comb_array(4)=1
Comb_array(5)=2
Comb_array(6)=4
Comb_array(7)=1
Comb_array(8)=3
Comb_array(9)=4
Comb_array(10)=2
Comb_array(11)=3
Comb_array(12)=4

vba

Imagino dois laços um dentro do outro, mas tentei escrever de trocentas maneiras e nada.

Data: 15/09/2019 Funcao que realiza todas combinacaoes 3x3 dos itens do vetor Nao implementado

Public Function aMake_Comb_x3(Array_Items() As String) As String()


    Dim Index1 As Integer
    Dim Index2 As Integer
    Dim index3 As Integer
    Dim Index4 As Integer
    Dim Comb_Array() As Integer
    Dim Array_Aux1() As Integer
    Dim Cont As Integer
    Dim Comb_Type As Integer
    Dim X As Integer

    Comb_Type = 3
    Index1 = 1
    Index2 = 2
    index3 = 3
    Index4 = 1

    X = 2

    'Redimensiona o vetor para a qtd. max. de combinacoes.
    'A posicao 0 sera Ignorada, para facilitar os calculos e loops no preenchimento
    ReDim Comb_Array((( WorksheetFunction. combin(UBound(Array_Items) + 1, Comb_Type)) * Comb_Type))

    'Redimensiona os vetores para ignorar a posicao "0"
    ReDim Array_Aux1(UBound(Array_Items) + 1)

    'Preenche o vetor auxiliar
    For Cont = 1 To UBound(Array_Items) + 1


        Array_Aux1(Cont) = Array_Items(Cont - 1)


    Next Cont


    For Index4 = 1 To UBound(Comb_Array)


        Comb_Array(Index4) = Array_Aux1(Index1)
        Index4 = Index4 + 1

        For Index2 = X To UBound(Array_Aux1)

            Comb_Array(Index4) = Array_Aux1(Index2)


            If Index2 Mod Comb_Type = 0 Then

                Index2 = X
                Exit For

            End If

            Index4 = Index4 + 1


            'If Index4 Mod Comb_Type = 0 Then

                'Index2 = Index2 * 2

            'End If

        Next Index2



    Next Index4



End Function

Caso alguém tenha uma idéia ou link com tal algoritmo ficaria grato. Gastei um tempão tentando e nada.

Desde já agradeço pela ajuda.

5
  • 1
    Não deu para perceber como chega da entrada ao resultado. Que combinação é essa que você aplica ?
    – Isac
    Commented 17/09/2019 às 22:38
  • Boa noite Isac. A idéia é através da entrada "Array_Items" chegar ao resultado mencionado "Comb_array". Com esse vetor agrupado onde possui os elementos combinados 3 a 3 de todas a formas sem repetição chego ao que preciso. O Vetor Array_Items é um vetor qualquer com diversos elementos numéricos. A idéia é realizar a combinação do conteúdo numérico e agrupar no vetor comb_Array. Não sei se ficou claro? Qualquer dúvida reformulo minha pergunta. Desde já agradeço a atenção dada. Obrigado! Commented 18/09/2019 às 0:22
  • Esqueci de mencionar. A combinação é a "clássica" combinação simples da matemática.C n,r. Ou seja um grupo de elementos (Vetor) tomados três a Três. Grato pela ajuda.! Commented 18/09/2019 às 0:34
  • @rangelssilva Poderia editar a pergunta com estas informações? E não sei se entendi bem, mas com combinação 3x3, você quer uma combinação de três elementos, de todas as possibilidades de combinação, sem importar a ordem, então não podem ter duplicatas? Pois, se por exemplo num array estiver inserido [1,1,2,3], o resultado teria o 1 duplicado ou não? E inserir em fila num array? Se sim, ao invés de fila, não seria melhor uma matriz multidimensional, ou um array of arrays? Commented 18/09/2019 às 12:24
  • Prezado, Daniel bom dia. Entendi seu questionamento. O vetor que entrará como argumento na função terá a consistência de dados verificada previamente. Então não há necessidade de verificação se existem elementos duplicados. O elementos nele serão únicos. E o resultado serão as combinações únicas. (Tomados 3 a 3). Acho que agora ficou mais claro. Fico grato com a ajuda. Commented 18/09/2019 às 14:12

2 Respostas 2

1

No código abaixo, a entrada foi um array arr = Array(5, 4, 3, 2, 1) e 3x3, ou seja, p = 3.

Então a função comb_elementos é chamada com o array e a quantidade de elementos como parâmetros: comb_elementos(arr, p)

E os resultados são dados numa matriz de nome result_matrix.

Código

Option Explicit
Private c As Long

Sub teste()
    Dim arr() As Variant
    Dim p As Long, i As Long, k As Long
    Dim result As String
    Dim result_matrix As Variant

    arr = Array(5, 4, 3, 2, 1)
'   ReDim arr(1 To 5)
'    arr(1) = 1
'    arr(2) = 2
'    arr(3) = 3
'    arr(4) = 4
'    arr(5) = 5
    p = 3

    result_matrix = comb_elementos(arr, p)

    'Verificar Resultado
    For i = LBound(result_matrix) To UBound(result_matrix)
        result = ""
        For k = 0 To p - 1
            result = result & " " & result_matrix(i, k)
        Next k
        Debug.Print Trim(result)
    Next i
End Sub

Function comb_elementos(arr() As Variant, p As Long)
    Dim combs_n As Variant
    Dim comb As Long, n As Long
    Dim result As Variant

    n = UBound(arr) - LBound(arr) + 1
    comb = WorksheetFunction.Combin(n, p)

    c = 0
    ReDim combs_n(0 To comb - 1, 0 To p - 1)

    combinacao combs_n, arr, p

    comb_elementos = combs_n
End Function

Private Function combinacao(combs_n As Variant, arr() As Variant, r As Long, Optional i As Long, Optional l As Long) As Long
    Dim x As Long, y As Long, n As Long

    If i <= LBound(arr) Then i = LBound(arr)
    If l < 1 Then l = 1
    If c < 1 Then c = 1
    If r = 0 Then
        combs_n(0, 0) = 1
        Exit Function
    End If

    For x = i To UBound(arr) - r + 1
        If r = 1 Then
            If c > 1 Then
                For y = 0 To l - 2
                    If combs_n(c - 1, y) = "" Then combs_n(c - 1, y) = combs_n(c - 2, y)
                Next
            End If
            combs_n(c - 1, l - 1) = arr(x)
            c = c + 1
        Else
            combs_n(c - 1, l - 1) = arr(x)
            combinacao combs_n, arr, r - 1, x + 1, l + 1
        End If
    Next
End Function

Resultado

O resultado pode ser verificado no código em que está comentado 'Verificar Resultado, em que o Debug.Print imprime na janela de verificação imediata:

Resultado Debug.Print

Ou verificando a variável combs_n na janela de variáveis:

Resultado na janela de variáveis

5
  • Bom dia, Daniel fico grato com a ajuda. A solução me pareceu interessante, mas notei que ao colocar um botão que chama a "Sub Teste" após realizar um segundo clique, a função apresenta erro na linha após o else. "Combs_n(c - 1, l - 1) = arr(x - 1)". Não entendi o porquê já que tenho um pouco de dificuldade com rotinas recursivas. Outro detalhe: você saberia me dizer se com essa rotina recursiva eu somente consigo armazenar a matriz com a resposta numa variável pública? Tirando o primeiro erro é até viável, mas sempre evito este tipo de implementação. Mesmo assim agradeço pela ajuda. No aguardo Commented 20/09/2019 às 12:25
  • Prezado, Coloquei o C=0 dentro da rotina e funcionou muito bem. Vou analisar o código e tentar implementar melhorias após estudar recursividade. Vou votar aqui! Grato pelo empenho e ajuda. Commented 21/09/2019 às 11:49
  • @rangelssilva não insira informações ao conteúdo das publicações de terceiros. Para realizar questionamentos ou exprimir dúvida use os comentários. As edições existem para melhorar visualmente o conteúdo e facilitar sua interpretação mas não devem ser usadas para inserir informações a revelia do autor. Commented 21/09/2019 às 12:27
  • @rangelssilva Veja o edit, corrigi um erro. Que se o vetor não começasse em 0, dava erros... Agora pode começar e terminar de qualquer index... E transformei em função, que retorna uma matriz. Commented 23/09/2019 às 11:47
  • Prezado Agradeço pelo empenho. Ficou muito bom. Funciona perfeitamente, e o melhor de tudo é que o código é genérico para quaisquer combinações desejadas. Inclusive fiz algumas adaptações e trabalhei com variáveis private. Vou avaliar positivamente, quando eu tiver reputação para isso. Vou postar a adaptação que fiz no fim de semana. Ela funciona também. Commented 23/09/2019 às 13:19
1

'No Começo do módulo coloquei As variáveis C e Combs_N como private. Agora seria somente chamar Comb_elementos() em qualquer parte do programa passando os argumentos que eu tenho o resultado.

Private Combs_n As Variant
Private c As Integer


Function comb_elementos(arr() As String, p As Long) As Variant

Dim comb As Long, n As Long
Dim result As Variant

c = 0

n = UBound(arr) - LBound(arr) + 1
comb = WorksheetFunction.Combin(n, p)

ReDim Combs_n(0 To comb - 1, 0 To p - 1)

comb_elementos = combinacao(arr, p)

'comb_elementos = Combs_n

End Function


'Utiliza Variaveis Private
'Funcionamento: Ok
Private Function combinacao(arr() As String, r As Long, Optional i As Long, Optional l As Long) As Variant


Dim x As Long, y As Long, n As Long


n = UBound(arr) - LBound(arr) + 1

If n < 1 Or r > n Or r < 0 Then Err.Raise 1
If i < 1 Then i = 1
If l < 1 Then l = 1
If c < 1 Then c = 1
If r = 0 Then
    Combs_n(0, 0) = 1
    Exit Function
End If

For x = i To n - r + 1
    If r = 1 Then
        If c > 1 Then
            For y = 0 To l - 2
                If Combs_n(c - 1, y) = "" Then Combs_n(c - 1, y) = Combs_n(c - 2, y)
            Next
        End If
        Combs_n(c - 1, l - 1) = arr(x - 1)
        c = c + 1
    Else
        Combs_n(c - 1, l - 1) = arr(x - 1)
        combinacao arr, r - 1, x + 1, l + 1
    End If
Next

combinacao = Combs_n

End Function

Você deve fazer log-in para responder a esta pergunta.

Esta não é a resposta que você está procurando? Pesquise outras perguntas com a tag .