locked
Ajuda em sub rotina.... RRS feed

  • Pergunta

  •    Fala galera do msdn, estou com o seguinte cenário: tenho uma célula onde a mesma será preechida com várias palavras seguidas por vírgula, exemplo: teste1, teste2, teste3 .

       Estou tentando fazer um subrotina que pegará as palavras deste célula e colocará em células de uma coluna, exmplo:   teste1

                                          teste2

                                          teste3

                                          teste4

     

      Já consegui fazer com a ferramenta "texto para colunas" , mas gostaria de fazer uma rotina, para ficar mais automatizado.

     

    Valeu

         

    terça-feira, 24 de outubro de 2006 20:17

Todas as Respostas

  • Boa noite.

    Você pode tentar o seguinte código:

    Public Sub Separa(rngOrigem As Range, rngDestino As Range)
      Dim aTokens As Variant
      Dim lngIndice As Long
      Dim intOffset As Integer
      If (Not IsEmpty(rngOrigem.Value)) Then
        aTokens = Split(CStr(rngOrigem.Value), ",")
        If (Not IsEmpty(aTokens)) Then
          intOffset = 0
          For lngIndice = LBound(aTokens) To UBound(aTokens)
            rngDestino.Offset(intOffset, 0).Value = aTokens(lngIndice)
            intOffset = intOffset + 1
          Next lngIndice
        End If
      End If
    End Sub
    

    Para chamar este procedimento imagine o seguinte cenário:

    1. Na célula A1 você tem o texto separado por vírgulas.
    2. Você quer que o resultado seja colocado a partir de A3, continuando por A4, A5, etc

    Para obter esse resultado use: Separa Range("A1"), Range("A3")

    Atenciosamente, 

    quarta-feira, 25 de outubro de 2006 00:46
  • Para eu chamar a função, eu tenho que digitar assim Separa Range("A1"), Range("A3")  em uma célula qualquer, ta dando erro...tentei sem aspas já......

    valeu meu garoto.
    quarta-feira, 25 de outubro de 2006 03:18
  • Bom dia.

    Tiago, o código acima é um procedimento (Sub) e não uma função (Function) e, como possui parâmetros, não pode ser chamado a partir de uma célula, mas de dentro do próprio VBA. Para tentar a melhor explicação, um embasamento teórico se faz necessário e é isso que tento passar a vc nas próximas linhas:

    Por uma restrição (não confundir restrição com limitação) do Excel, uma função escrita em VBA só pode alterar o conteúdo de células quando não for projetada para ser invocada de dentro de uma célula (como parte de uma fórmula, por exemplo). Como o procedimento acima descrito altera o conteúdo de células (a partir de A3, por exemplo) ele não pode ser invocado a partir de uma fórmula e, exatamente por isso, foi projetado como Sub e não como Function. Uma vez que possui parâmetros, para torná-lo mais genérico, tambem não pode ser invocado através do comando de menú Ferramentas, Macro, Macros ...

    Assim você deve acrescentar ao seu módulo um outro procedimento que invoque o código que te passei com valores específicos para os parâmetros e que, ao mesmo tempo, não possua parâmetros, de forma a poder ser invocado como uma Macro pelo Excel.

    Face ao acima exposto, imaginemos o cenário específico em que você tenha um conjunto de palavras separadas por vírgulas na célula A1 e queira que estas palavras apareçam separadas a partir da célula A3. Para esse caso específico você deve proceder como segue:

    1. Copie o seguinte código para um módulo de código padrão do VBA (pode ser o mesmo onde você colou o código para Separa():
      Public Sub SeparaEmA1ParaA3()
        Separa Range("A1"), Range("A3")
      End Sub
    2. Agora, de dentro de sua planilha, você pode invocar o procedimento acima usando o menú Ferramentas, Macro, Macros ... e selecionando a macro SeparaEmA1ParaA3 que aparece na listagem. 

    Sei que parece chato esse monte de considerações teóricas, mas é através delas, e somente delas, que se consegue escrever códigos robustos. Caso você não consiga adaptar o código às suas necessidades específicas, poste aqui a célula onde estão as palavras separadas por vírgula, a célula a partir da qual você quer os resultados e eu criarei o código específico para aquela situação.

    Atenciosamente,

     

    quarta-feira, 25 de outubro de 2006 11:20
  • Po Otávio, vc é show de bola heim cara, muito obrigado mesmo.........

    O código faz o que eu quero....só gostaria de deletar os dados da coluna antes de passar os dados da célula para coluna..........

    se não tiver muito ocupado pode me explicar o que faz o procedimento?

    ou somente as funcao

    IsEmpty(rngOrigem.Value) => Essa parace que verifica se a célula está vazia né....

    Split(CStr(rngOrigem.Value) =>

    LBound(aTokens) =>

    UBound(aTokens) =>

    rngDestino.Offset(intOffset, 0).Value = aTokens(lngIndice)   =>

     

    Valeu meu garotooooooooo

    quarta-feira, 25 de outubro de 2006 16:38
  • Olá,

    alterei o código para que as células de destino sejam limpas antes de serem preenchidas com os novos resultados:

    Public Sub Separa(rngOrigem As Range, rngDestino As Range)
      'aTokens receberá uma matriz com todas as palavras
      'individuais extraídas
      Dim aTokens As Variant
      'Índice para acessar cada elemento individual de aTokens
      Dim lngIndice As Long
      'intOffset guardará o deslocamento da próxima célula a
      'preencher, com base na célula inicial rngDestino
      Dim intOffset As Integer
      'Última célula preenchida, abaixo de rngDestino
      'Este procedimento apagará o conteúdo de todas as
      'células no intervalo rngDestino:rngUltimaCelula
      Dim rngUltimaCelula As Range
      'Primeiramente, verifica se existe um valor informado
      'em rngOrigem
      If (Not IsEmpty(rngOrigem.Value)) Then
        'Cria uma matriz com o texto em rngOrigem.Value
        'devidamente separado através das ocorrências das vírgulas
        'Assim, o texto Otávio,Alves,Ribeiro "preencherá"
        'aTokens com uma matriz de tres elementos a saber:
        '
        'aTokens(0)="Otávio"
        'aTokens(1)="Alves"
        'aTokens(2)="Ribeiro"
        aTokens = Split(CStr(rngOrigem.Value), ",")
        'Verifica se aTokens foi "preenchido" corretamente,
        'prossegue.
        If (Not IsEmpty(aTokens)) Then
          'Prepara-se para apagar o conteúdo do intervalo que
          'se inicia em rngDestino e se estende até
          'a última célula preenchida abaixo dela (contígua)
          Set rngUltimaCelula = rngDestino.End(xlDown)
          Range(rngDestino, rngUltimaCelula).ClearContents
          'A primeira célula a ser preenchida com os resultados
          'está a ZERO linhas abaixo de rngDestino, portanto ela mesma
          intOffset = 0
          'LBound pega o índice do primeiro elemento de aTokens
          'no caso, aTokens(LBound(aTokens)) retorna "Otávio"
          '
          'UBound retorna o índice do último elemento em aTokens
          'no caso aTokens(UBound(aTokens))="Ribeiro"
          For lngIndice = LBound(aTokens) To UBound(aTokens)
            'Preenche o intervalo a partir de rngDestino
            'com os valores presentes em aTokens
            rngDestino.Offset(intOffset, 0).Value = aTokens(lngIndice)
            'informa que o próximo resultado deve ser colocado
            'uma linha abaixo do resultado anterior
            intOffset = intOffset + 1
          Next lngIndice
        End If
      End If
    End Sub
    

    Atenciosamente,

    quarta-feira, 25 de outubro de 2006 21:15
  • Valeu...quando eu chegar no serviço vou testar...po valeu mesmo, cara qq coisa pode mandar email.........sql, php, o que puder eu ajudo...
    quinta-feira, 26 de outubro de 2006 03:48