Função VBA - Validador de CNPJ

Nesta postagem, estou disponibilizando a função VBA, ou seja, fórmula personalizada para Excel.

Segue o procedimento:

1º Pressione Alt+F11
2º Clique no Menu>Inserir>Modulo e cole o código abaixo.
3º Após isso clique na célula e digite =VALIDADOR_CNPJ(a celula que contem o cnpj)



Public Function VALIDADOR_CNPJ(CNPJ As String) As String
   
    Dim VarDigito1 As Integer
    Dim VarDigito2 As Integer
    Dim VarDigito3 As Integer
    Dim VarDigito4 As Integer
    Dim VarDigito5 As Integer
    Dim VarDigito6 As Integer
    Dim VarDigito7 As Integer
    Dim VarDigito8 As Integer
    Dim VarDigito9 As Integer
    Dim VarDigito10 As Integer
    Dim VarDigito11 As Integer
    Dim VarDigito12 As Integer
    Dim VarDigito13 As Integer
    Dim VarDigito14 As Integer
    Dim VarCalcDigito1 As Integer
    Dim VarCalcDigito2 As Integer
    Dim VarUltDig As Integer
   
    'Função adiciona o valor 0 à esquerda se não conter 14 dígitos.
    If Len(CNPJ) < 14 Then
       
        CNPJ = String(14 - Len(CNPJ), "0") & CNPJ
       
    End If
   
    'Variável recebe a posição do último dígito.
    VarUltDig = Len(CNPJ)
   
    'Sai da função caso a célula esteja vazia
    If CNPJ = Empty Then
       
        VALIDADOR_CNPJ = Empty
       
        Exit Function
       
    End If
   
    'Variáveis recebe o valor correspondente a cada dígito.
   
    VarDigito1 = CInt(Mid(CNPJ, VarUltDig - 13, 1))
    VarDigito2 = CInt(Mid(CNPJ, VarUltDig - 12, 1))
    VarDigito3 = CInt(Mid(CNPJ, VarUltDig - 11, 1))
    VarDigito4 = CInt(Mid(CNPJ, VarUltDig - 10, 1))
    VarDigito5 = CInt(Mid(CNPJ, VarUltDig - 9, 1))
    VarDigito6 = CInt(Mid(CNPJ, VarUltDig - 8, 1))
    VarDigito7 = CInt(Mid(CNPJ, VarUltDig - 7, 1))
    VarDigito8 = CInt(Mid(CNPJ, VarUltDig - 6, 1))
    VarDigito9 = CInt(Mid(CNPJ, VarUltDig - 5, 1))
    VarDigito10 = CInt(Mid(CNPJ, VarUltDig - 4, 1))
    VarDigito11 = CInt(Mid(CNPJ, VarUltDig - 3, 1))
    VarDigito12 = CInt(Mid(CNPJ, VarUltDig - 2, 1))
    VarDigito13 = CInt(Mid(CNPJ, VarUltDig - 1, 1))
    VarDigito14 = CInt(Mid(CNPJ, VarUltDig, 1))
   
    'Cálculo do Primeiro Dígito.
    VarCalcDigito1 = (VarDigito1 * 6) + (VarDigito2 * 7) + (VarDigito3 * 8) + (VarDigito4 * 9) + _
    (VarDigito5 * 2) + (VarDigito6 * 3) + (VarDigito7 * 4) + (VarDigito8 * 5) + (VarDigito9 * 6) + _
    (VarDigito10 * 7) + (VarDigito11 * 8) + (VarDigito12 * 9)
   
    VarCalcDigito1 = VarCalcDigito1 Mod 11   'Cálculo do Resto.
    'se o resto for igual a 10 recebe o valor 0
    If VarCalcDigito1 = 10 Then
       
        VarCalcDigito1 = 0
       
    End If
   
    'Cálculo do Segundo Dígito.
    VarCalcDigito2 = (VarDigito1 * 5) + (VarDigito2 * 6) + (VarDigito3 * 7) + (VarDigito4 * 8) + _
    (VarDigito5 * 9) + (VarDigito6 * 2) + (VarDigito7 * 3) + (VarDigito8 * 4) + (VarDigito9 * 5) + _
    (VarDigito10 * 6) + (VarDigito11 * 7) + (VarDigito12 * 8) + (VarCalcDigito1 * 9)
    VarCalcDigito2 = VarCalcDigito2 Mod 11    'Cálculo do Resto.
   
    'se o resto for igual a 10 recebe o valor 0
    If VarCalcDigito2 = 10 Then
        VarCalcDigito2 = 0
    End If
   
    'Fazendo a validação dos dados calculado x informado
    If VarDigito13 = VarCalcDigito1 And VarDigito14 = VarCalcDigito2 Then
       
        VALIDADOR_CNPJ = "CNPJ Válido"
       
    Else
   
        VALIDADOR_CNPJ = "CNPJ Inválido"
       
    End If


End Function

Comentários

  1. Unknown14 de junho de 2018 às 12:01

    Este comentário foi removido pelo autor.

    ResponderExcluir
  2. Unknown14 de junho de 2018 às 12:02

    Este comentário foi removido pelo autor.

    ResponderExcluir
  3. Unknown14 de junho de 2018 às 12:04

    Public Function validateCNPJ(cnpj As String) As Boolean

    Dim digits(13) As Variant

    Dim stCalc As Variant: stCalc = Array(6, 7, 8, 9, 2, 3, 4, 5, 6, 7, 8, 9)
    Dim ndCalc As Variant: ndCalc = Array(5, 6, 7, 8, 9, 2, 3, 4, 5, 6, 7, 8, 9)

    Dim stRes As Long
    Dim ndRes As Long

    If Len(cnpj) < 14 Then

    cnpj = String(14 - Len(cnpj), "0") & cnpj

    End If

    For i = LBound(digits) To UBound(digits)

    digits(i) = Mid(cnpj, i + 1, 1)

    Next

    For i = LBound(stCalc) To UBound(stCalc)

    stRes = stRes + (digits(i) * stCalc(i))
    ndRes = ndRes + (digits(i) * ndCalc(i))

    Next

    stRes = stRes Mod 11

    If stRes = 10 Then stRes = 0

    ndRes = ndRes + (stRes * ndCalc(LBound(ndCalc)))

    ndRes = ndRes Mod 11

    If ndRes = 10 Then ndRes = 0

    If digits(12) = stRes And digits(13) = ndRes Then validateCNPJ = True Else validateCNPJ = False

    End Function

    ResponderExcluir
    Respostas
    1. Cleison3 de dezembro de 2021 às 11:42

      na linha ndRes = ndRes + (stRes * ndCalc(LBound(ndCalc))), troque o LBound por UBound. o restante está 100%, muito obrigado pela ajuda

      Excluir
  4. Unknown22 de abril de 2022 às 07:27

    Obrigada!

    ResponderExcluir

Postar um comentário

Postagens mais visitadas deste blog

Autocorreção no Excel - Eu Escrevo e o Excel Corrige.

Imagem
Os aplicativos Microsoft Office Excel possui um mecanismo  de correção automática que permite o Excel mudar automaticamente uma palavra digitada erroneamente, de acordo com a lista de palavras pré cadastradas no Excel. Muitos usuários acreditam ser erro do Microsoft Office Excel, mas, ao contrário do que parece, o recurso é bastante útil, pois, podemos cadastrar uma lista de palavras erradas, para que o Excel altere automaticamente, ou seja, efetue a correção instantânea. Portanto, em alguns dos casos o usuário pode querer deixar a palavra errada. Exemplo.:. UN Se digitarmos dessa forma, o Excel automaticamente altera para UM, neste caso específico, devemos excluir a palavra "UN" da lista de autocorreção, conforme procedimento abaixo. Menu>Arquivo>Opções
Leia mais

Função VBA - Busca Distância Entre Cidades

Imagem
A função abaixo tem como objetivo buscar a distância entre duas cidades. No entrando, os comandos necessitam que a referência "Microsoft XML, v6.0" esteja ativada. Habilite a referencia acima e cole o código abaixo em um módulo VBA. Function Busca_Km(Origem As String, Destino As String) As Double     'Requer referência ao: 'Microsoft XML, v6.0'     Dim Solicitacao As XMLHTTP60     Dim Doc As DOMDocument60     Dim Distancia_Pontos As IXMLDOMNode     Let Busca_Km = 0     'Checa e limpa as entradas     On Error GoTo Sair     Let Origin = Replace(Origem, " ", "%20")     Let Destination = Replace(Destino, " ", "%20")     ' Le os dados XML da API do Google Maps.     Set Solicitacao = New XMLHTTP60     Solicitacao.Open "GET", "http://maps.googleapis.com/maps/api/directions/xml?origin=" _         & Origin & "&destinatio...
Leia mais