Ir para conteúdo
Fórum Script Brasil
  • 0

Função Countifs no vba

Riolan

Perguntado por Riolan,

 Share

Pergunta

Riolan

Riolan

Postado
Postado (editado)

Necessito pesquisar uma tabela de 30 colunas por +/- 2000 linhas, contendo codigos de tendimento em serviço de saude. As colunas são indicativas de diagnóstico e intercorrencias em um mesmo paciente. A pesquisa deve ser realizada nas combinações de 5 a 10 entre as 30 colunas. Porém ta dndo o erro "1004" após a realizaçõ do 1º laço do loop. O erro dá na linha da funçõ CountIfs. Abaixo o codigo: 

Sub Afinidade()
'
' Afinidade Macro
'

'
    Dim lin1 As Integer
    Dim lin2 As Integer
    Dim linE As Integer
    Dim lin5 As Integer
    Dim lin6 As Integer
    Dim lin7 As Integer
    Dim lin8 As Integer
    Dim lin9 As Integer
    Dim linR As Integer
    Dim colM1 As Integer
    Dim colM2 As Integer
    Dim colM3 As Integer
    Dim colM4 As Integer
    Dim colM5 As Integer
    Dim colM6 As Integer
    Dim colM7 As Integer
    Dim colM8 As Integer
    Dim colM9 As Integer
    Dim colM10 As Integer
    Dim colM11 As Integer
    Dim colP1 As Integer
    Dim colP2 As Integer
    Dim colP3 As Integer
    Dim colP4 As Integer
    Dim colP5 As Integer
    Dim colP6 As Integer
    Dim colP7 As Integer
    Dim colP8 As Integer
    Dim colP9 As Integer
    Dim colP10 As Integer
    Dim colR As Integer
    Dim num1 As Integer
    Dim num2 As Integer
    Dim num3 As Integer
    Dim num4 As Integer
    Dim num5 As Integer
    Dim num6 As Integer
    Dim num7 As Integer
    Dim num8 As Integer
    Dim num9 As Integer
    Dim num10 As Integer
    Dim rm(25) As Range

    Worksheets("Plan3").Activate
    Set rm(1) = Range("C2:C521")
    Set rm(2) = Range("D2:D521")
    Set rm(3) = Range("E2:E521")
    Set rm(4) = Range("F2:F521")
    Set rm(5) = Range("G2:G521")
    Set rm(6) = Range("H2:G521")
    Set rm(7) = Range("I2:I251")
    Set rm(8) = Range("J2:J251")
    Set rm(9) = Range("K2:K251")
    Set rm(10) = Range("L2:L251")
    Set rm(11) = Range("M2:M251")
    Set rm(12) = Range("N2:N251")
    Set rm(13) = Range("O2:O251")
    Set rm(14) = Range("P2:P251")
    Set rm(15) = Range("Q2:Q251")
    Set rm(16) = Range("R2:R251")
    Set rm(17) = Range("S2:S251")
    Set rm(18) = Range("T2:T251")
    Set rm(19) = Range("U2:U251")
    Set rm(20) = Range("V2:V251")
    Set rm(21) = Range("Y2:Y251")
    Set rm(22) = Range("X2:X251")
    Set rm(23) = Range("W2:W251")
    Set rm(24) = Range("Z2:Z251")
    Set rm(25) = Range("AA2:AA251")
    lin1 = 2
    lin2 = 521
    lin5 = 0
    lin6 = 0
    lin7 = 0
    lin8 = 0
    lin9 = 0
    linR = 2
    colR = 40
    afim = 0
    colP1 = 29
    colP2 = 30
    colP3 = 31
    colP4 = 32
    colP5 = 33
    colP6 = 34
    colP7 = 35
    colP8 = 36
    colP9 = 37
    colP10 = 38
'-------Pesquisa de 5
    For num1 = 1 To 21
        colM1 = num1 + 2
        For num2 = num1 + 1 To 22
            colM2 = num2 + 2
            For num3 = num2 + 1 To 23
                colM3 = num3 + 2
                For num4 = num3 + 1 To 24
                    colM4 = num4 + 2
                    For num5 = num4 + 1 To 25
                        colM5 = num5 + 2
                      ' Application.
                        Worksheets("Plan2").Activate
                        Range("A601:H608").Formula = "=Rand()"
                        Worksheets("Plan3").Activate
                        
                        afim = WorksheetFunction.CountIfs(rm(num1), num1, rm(num2), num2, _
                                                          rm(num3), num3, rm(num4), num4, _
                                                          rm(num5), num5)
                        If afim <> 0 Then
                            Cells(linR, colP1).Value = num1
                            Cells(linR, colP2).Value = num2
                            Cells(linR, colP3).Value = num3
                            Cells(linR, colP4).Value = num4
                            Cells(linR, colP5).Value = num5
                            Cells(linR, colR).Value = afim
                            Cells(linR, colR + 1).Value = lin2
                            afim = 0
                            linR = linR + 1
                        Else
                            Cells(linR, colP1).Value = num1
                            Cells(linR, colP2).Value = num2
                            Cells(linR, colP3).Value = num3
                            Cells(linR, colP4).Value = num4
                            Cells(linR, colP5).Value = num5
                            Cells(linR, colR).Value = afim
                            Cells(linR, colR + 1).Value = lin2
                        End If
                    Next num5
                Next num4
            Next num3
        Next num2
    Next num1
'Range("A1").Value = ""
    
'---------Pesquisa de 6
    lin5 = linR
    For linE = 1 To lin5
        num1 = Cells(linE, colP1).Value
        num2 = Cells(linE, colP2).Value
        num3 = Cells(linE, colP3).Value
        num4 = Cells(linE, colP4).Value
        num5 = Cells(linE, colP5).Value
        For num6 = num5 + 1 To 25
            colM6 = num6 + 2
            afim = Application.WorksheetFunction.CountIfs(rm(num1), num1, rm(num2), num2, _
                                                          rm(num3), num3, rm(num4), num4, _
                                                          rm(num5), num5, rm(num6), num6)
            If afim <> 0 Then
                 Cells(linR, colP1).Value = num1
                 Cells(linR, colP2).Value = num2
                 Cells(linR, colP3).Value = num3
                 Cells(linR, colP4).Value = num4
                 Cells(linR, colP5).Value = num5
                 Cells(linR, colP6).Value = num6
                 Cells(linR, colR).Value = afim
                 Cells(linR, colR + 1).Value = lin2
                 afim = 0
                 linR = linR + 1
                 Cells(linE, colP1).Value = 0
                 Cells(linE, colP2).Value = 0
                 Cells(linE, colP3).Value = 0
                 Cells(linE, colP4).Value = 0
                 Cells(linE, colP5).Value = 0
             Else
                 Cells(linR, colP1).Value = num1
                 Cells(linR, colP2).Value = num2
                 Cells(linR, colP3).Value = num3
                 Cells(linR, colP4).Value = num4
                 Cells(linR, colP5).Value = num5
                 Cells(linR, colP6).Value = num6
                 Cells(linR, colR).Value = afim
                 Cells(linR, colR + 1).Value = lin2
              End If
         Next num6
    Next linE
'---------Pesquisa de 7
    lin6 = linR
    For linE = lin5 + 1 To lin6
        num1 = Cells(linE, colP1).Value
        num2 = Cells(linE, colP2).Value
        num3 = Cells(linE, colP3).Value
        num4 = Cells(linE, colP4).Value
        num5 = Cells(linE, colP5).Value
        num6 = Cells(linE, colP6).Value
        For num7 = num6 + 1 To 25
            colM7 = num7 + 2
            afim = Application.WorksheetFunction.CountIfs(rm(num1), num1, rm(num2), num2, _
                                                          rm(num3), num3, rm(num4), num4, _
                                                          rm(num5), num5, rm(num6), num6, _
                                                          rm(num7), num7)
            If afim <> 0 Then
                 Cells(linR, colP1).Value = num1
                 Cells(linR, colP2).Value = num2
                 Cells(linR, colP3).Value = num3
                 Cells(linR, colP4).Value = num4
                 Cells(linR, colP5).Value = num5
                 Cells(linR, colP6).Value = num6
                 Cells(linR, colP7).Value = num7
                 Cells(linR, colR).Value = afim
                 Cells(linR, colR + 1).Value = lin2
                 afim = 0
                 linR = linR + 1
                 Cells(linE, colP1).Value = 0
                 Cells(linE, colP2).Value = 0
                 Cells(linE, colP3).Value = 0
                 Cells(linE, colP4).Value = 0
                 Cells(linE, colP5).Value = 0
                 Cells(linE, colP6).Value = 0
                 Cells(linE, colP7).Value = 0
             Else
                 Cells(linR, colP1).Value = num1
                 Cells(linR, colP2).Value = num2
                 Cells(linR, colP3).Value = num3
                 Cells(linR, colP4).Value = num4
                 Cells(linR, colP5).Value = num5
                 Cells(linR, colP6).Value = num6
                 Cells(linR, colP7).Value = num7
                 Cells(linR, colR).Value = afim
                 Cells(linR, colR + 1).Value = lin2
              End If
         Next num7
    Next linE
'---------Pesquisa de 8
    lin7 = linR
    For linE = lin6 + 1 To lin7
        num1 = Cells(linE, colP1).Value
        num2 = Cells(linE, colP2).Value
        num3 = Cells(linE, colP3).Value
        num4 = Cells(linE, colP4).Value
        num5 = Cells(linE, colP5).Value
        num6 = Cells(linE, colP6).Value
        num7 = Cells(linE, colP7).Value
        For num8 = num7 + 1 To 25
            colM8 = num8 + 2
            afim = Application.WorksheetFunction.CountIfs(rm(num1), num1, rm(num2), num2, _
                                                          rm(num3), num3, rm(num4), num4, _
                                                          rm(num5), num5, rm(num6), num6, _
                                                          rm(num7), num7, rm(num8), num8)
            If afim <> 0 Then
                 Cells(linR, colP1).Value = num1
                 Cells(linR, colP2).Value = num2
                 Cells(linR, colP3).Value = num3
                 Cells(linR, colP4).Value = num4
                 Cells(linR, colP5).Value = num5
                 Cells(linR, colP6).Value = num6
                 Cells(linR, colP7).Value = num7
                 Cells(linR, colP8).Value = num8
                 Cells(linR, colR).Value = afim
                 Cells(linR, colR + 1).Value = lin2
                 afim = 0
                 linR = linR + 1
                 Cells(linE, colP1).Value = 0
                 Cells(linE, colP2).Value = 0
                 Cells(linE, colP3).Value = 0
                 Cells(linE, colP4).Value = 0
                 Cells(linE, colP5).Value = 0
                 Cells(linE, colP6).Value = 0
                 Cells(linE, colP7).Value = 0
             Else
                 Cells(linR, colP1).Value = num1
                 Cells(linR, colP2).Value = num2
                 Cells(linR, colP3).Value = num3
                 Cells(linR, colP4).Value = num4
                 Cells(linR, colP5).Value = num5
                 Cells(linR, colP6).Value = num6
                 Cells(linR, colP7).Value = num7
                 Cells(linR, colP8).Value = num8
                 Cells(linR, colR).Value = afim
                 Cells(linR, colR + 1).Value = lin2
              End If
         Next num8
    Next linE
'---------Pesquisa de 9
    lin8 = linR
    For linE = lin7 + 1 To lin8
        num1 = Cells(linE, colP1).Value
        num2 = Cells(linE, colP2).Value
        num3 = Cells(linE, colP3).Value
        num4 = Cells(linE, colP4).Value
        num5 = Cells(linE, colP5).Value
        num6 = Cells(linE, colP6).Value
        num7 = Cells(linE, colP7).Value
        num8 = Cells(linE, colP8).Value
        For num9 = num8 + 1 To 25
            colM9 = num9 + 2
            afim = Application.WorksheetFunction.CountIfs(rm(num1), num1, rm(num2), num2, _
                                                          rm(num3), num3, rm(num4), num4, _
                                                          rm(num5), num5, rm(num6), num6, _
                                                          rm(num7), num7, rm(num8), num8, _
                                                          rm(num9), num9)
            If afim <> 0 Then
                 Cells(linR, colP1).Value = num1
                 Cells(linR, colP2).Value = num2
                 Cells(linR, colP3).Value = num3
                 Cells(linR, colP4).Value = num4
                 Cells(linR, colP5).Value = num5
                 Cells(linR, colP6).Value = num6
                 Cells(linR, colP7).Value = num7
                 Cells(linR, colP8).Value = num8
                 Cells(linR, colP9).Value = num9
                 Cells(linR, colR).Value = afim
                 Cells(linR, colR + 1).Value = lin2
                 afim = 0
                 linR = linR + 1
                 Cells(linE, colP1).Value = 0
                 Cells(linE, colP2).Value = 0
                 Cells(linE, colP3).Value = 0
                 Cells(linE, colP4).Value = 0
                 Cells(linE, colP5).Value = 0
                 Cells(linE, colP6).Value = 0
                 Cells(linE, colP7).Value = 0
                 Cells(linE, colP8).Value = 0
             Else
                 Cells(linR, colP1).Value = num1
                 Cells(linR, colP2).Value = num2
                 Cells(linR, colP3).Value = num3
                 Cells(linR, colP4).Value = num4
                 Cells(linR, colP5).Value = num5
                 Cells(linR, colP6).Value = num6
                 Cells(linR, colP7).Value = num7
                 Cells(linR, colP8).Value = num8
                 Cells(linR, colP9).Value = num9
                 Cells(linR, colR).Value = afim
                 Cells(linR, colR + 1).Value = lin2
              End If
         Next num9
    Next linE
'---------Pesquisa de 10
    lin9 = linR
    For linE = lin8 + 1 To lin9
        num1 = Cells(linE, colP1).Value
        num2 = Cells(linE, colP2).Value
        num3 = Cells(linE, colP3).Value
        num4 = Cells(linE, colP4).Value
        num5 = Cells(linE, colP5).Value
        num6 = Cells(linE, colP6).Value
        num7 = Cells(linE, colP7).Value
        num8 = Cells(linE, colP8).Value
        num9 = Cells(linE, colP9).Value
        For num10 = num9 + 1 To 25
            colM10 = num10 + 2
            afim = Application.WorksheetFunction.CountIfs(rm(num1), num1, rm(num2), num2, _
                                                          rm(num3), num3, rm(num4), num4, _
                                                          rm(num5), num5, rm(num6), num6, _
                                                          rm(num7), num7, rm(num8), num8, _
                                                          rm(num9), num9)
            If afim <> 0 Then
                 Cells(linR, colP1).Value = num1
                 Cells(linR, colP2).Value = num2
                 Cells(linR, colP3).Value = num3
                 Cells(linR, colP4).Value = num4
                 Cells(linR, colP5).Value = num5
                 Cells(linR, colP6).Value = num6
                 Cells(linR, colP7).Value = num7
                 Cells(linR, colP8).Value = num8
                 Cells(linR, colP9).Value = num9
                 Cells(linR, colP10).Value = num10
                 Cells(linR, colR).Value = afim
                 Cells(linR, colR + 1).Value = lin2
                 afim = 0
                 linR = linR + 1
                 Cells(linE, colP1).Value = 0
                 Cells(linE, colP2).Value = 0
                 Cells(linE, colP3).Value = 0
                 Cells(linE, colP4).Value = 0
                 Cells(linE, colP5).Value = 0
                 Cells(linE, colP6).Value = 0
                 Cells(linE, colP7).Value = 0
                 Cells(linE, colP8).Value = 0
                 Cells(linE, colP9).Value = 0
             Else
                 Cells(linR, colP1).Value = num1
                 Cells(linR, colP2).Value = num2
                 Cells(linR, colP3).Value = num3
                 Cells(linR, colP4).Value = num4
                 Cells(linR, colP5).Value = num5
                 Cells(linR, colP6).Value = num6
                 Cells(linR, colP7).Value = num7
                 Cells(linR, colP8).Value = num8
                 Cells(linR, colP9).Value = num9
                 Cells(linR, colP10).Value = num10
                 Cells(linR, colR).Value = afim
                 Cells(linR, colR + 1).Value = lin2
              End If
         Next num10
    Next linE
End Sub

Alguém pode me ajudar ?

Editado por kuroi
Adicionar tag CODE
Link para o comentário
Compartilhar em outros sites

0 respostass a esta questão

Posts Recomendados

Até agora não há respostas para essa pergunta

Participe da discussão

Você pode postar agora e se registrar depois. Se você já tem uma conta, acesse agora para postar com sua conta.

Visitante
Responder esta pergunta...

×   Você colou conteúdo com formatação.   Remover formatação

  Apenas 75 emoticons são permitidos.

×   Seu link foi incorporado automaticamente.   Exibir como um link em vez disso

×   Seu conteúdo anterior foi restaurado.   Limpar Editor

×   Você não pode colar imagens diretamente. Carregar ou inserir imagens do URL.

×
 Share
Ir para lista de Perguntas


  • Estatísticas dos Fóruns

    • Tópicos
      152,2k
    • Posts
      652k
×
×
  • Criar Novo...