Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Macro para algarism...
 
Notifications
Clear all

Macro para algarismos

 
Página 2 / 2
2024 - VBA & Macros
Post Recente por acarloos 11 anos atrás
20 Posts
2 Usuários
0 Reactions
3,013 Visualizações
RSS
 acarloos
(@acarloos)
Posts: 40
Eminent Member
Topic starter
 

Boa tarde pessoal,

Gostaria de um auxilio de vocês. Tenho um macro onde ele faz o seguinte, quando clico em uma célula o valor nessa célula vai pra uma outra célula de minha escolha. O macro é esse :
[Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(ActiveCell, Range("AD17:AD21")) Is Nothing Then Range("AB2").Value2 = ActiveCell.Value2]
End Sub

O que eu procuro é uma variação desse macro onde assim que eu clicar em um valor de uma determinada matriz ou célula, os algarismos que formam o valor fossem um para cada célula. Exemplificando, tenho valores nesse intervalo "H5:I7" ai assim que eu clicar uma vez em um dos valores, os algarismos que o formam fossem para as células (C5;C6;C7). No meu caso os valores que uso possuem vírgula, por exemplo 2,40 que está na célula I5, assim que eu clicar nesse valor o algarismo 2 vai pra célula C5, o algarismo 4 para C6 e o algarismo 0 para C7.

Na planilha abaixo dei um jeito de fazer usando a fórmula (=EXT.TEXTO) só que fazendo dessa forma o valor fica atrelado somente a uma célula e por macro fica melhor por causa da diversidade de valores que posso colocar nessas células. Vocês poderiam me ajudar nisso ?

Att.

acarloos

 
Postado : 15/01/2015 11:48 am
 gtsalikis
(@gtsalikis)
Posts: 2373
Noble Member
 

Como assim, juntar os 2?

Lembre-se de AGRADECER aos que te ajudaram, e de marcar o tópico como [Resolvido]
Gente que cuida de gente.

Gilmar

 
Postado : 06/02/2015 2:55 pm
 acarloos
(@acarloos)
Posts: 40
Eminent Member
Topic starter
 

Fazer os 2 funcionarem na mesma planilha.

 
Postado : 06/02/2015 5:10 pm
 gtsalikis
(@gtsalikis)
Posts: 2373
Noble Member
 

Bom, quando vc queria juntar os 2, acho que é meio óbvio que vão funcionar na mesma planilha.

Mas, como eu não entendi o que vc quer, e vc não explicou, vamos esperar e ver se alguém entendeu...

Lembre-se de AGRADECER aos que te ajudaram, e de marcar o tópico como [Resolvido]
Gente que cuida de gente.

Gilmar

 
Postado : 06/02/2015 5:28 pm
 acarloos
(@acarloos)
Posts: 40
Eminent Member
Topic starter
 

Só quero saber como colocá-las no VBA para que essas duas macros funcionem no Plan1. Quando coloco uma após a outra aparece "Erro de compilação : Nome repetido encontrado: Worksheet_SelectionChange."

 
Postado : 06/02/2015 9:00 pm
 acarloos
(@acarloos)
Posts: 40
Eminent Member
Topic starter
 

Gtsalikis, Obrigado pelas macros, agradeço por demais sua ajuda. Me desculpe se não expliquei como deveria. Acabei encontrando uma forma dessas duas macros funcionarem juntas. 

        Option Explicit
        Private Sub Worksheet_SelectionChange(ByVal Target As Range)
                    My_Sub_A Target
                    My_Sub_B Target
        End Sub
        
        Private Sub My_Sub_A(ByVal Target As Range)
        
        Dim valor       As String
        Dim i           As Long
        Dim j           As Long
        Dim l           As Long
        Dim k           As Long
        Dim h           As Long
        Dim qtd         As Long
        Dim destin()    As Range
        Dim intervalo() As Range

        j = 4 'Coloque aqui a quantidade de intervalos que vai usar

        ReDim intervalo(1 To j) As Range
        ReDim destin(1 To j) As Range
       
        Set intervalo(1) = Range("H5:I7") 'Para cada novo intervalo, repita essa linha, e aumente um numero no contador do intervalo
        Set intervalo(2) = Range("H9:I11") 'Para cada novo intervalo, repita essa linha, e aumente um numero no contador do intervalo
        Set intervalo(3) = Range("K5:L7") 'Para cada novo intervalo, repita essa linha, e aumente um numero no contador do intervalo
        Set intervalo(4) = Range("K9:L11") 'Para cada novo intervalo, repita essa linha, e aumente um numero no contador do intervalo

        Set destin(1) = Range("C5") 'coloque aqui a célula correspondente ao intervalo
        Set destin(2) = Range("C7") 'coloque aqui a célula correspondente ao intervalo
        Set destin(3) = Range("C9") 'coloque aqui a célula correspondente ao intervalo
        Set destin(4) = Range("C11") 'coloque aqui a célula correspondente ao intervalo

        For i = 1 To j
            If Not Intersect(ActiveCell, intervalo(i)) Is Nothing Then GoTo DISTRIBUIR
        Next i
        Exit Sub

DISTRIBUIR:

        qtd = 3 'digite aqui a quantidade de dígitos que quer considerar

        k = destin(i).Row
        h = destin(i).Column

        valor = Replace(Format(CStr(ActiveCell.Value2), "0.00"), ",", "")

        j = qtd - Len(valor)
        l = 1
        For i = h To qtd + h
            If i < j Then
                Cells(k, i).ClearContents
            Else
                Cells(k, i).Value2 = Mid(valor, l, 1)
                l = l + 1
            End If
        Next i

        End Sub
        
        Private Sub My_Sub_B(ByVal Target As Range)
        
        Dim valor       As String
        Dim i           As Long
        Dim j           As Long
        Dim l           As Long
        Dim k           As Long
        Dim h           As Long
        Dim qtd         As Long
        Dim destin()    As Range
        Dim intervalo() As Range

        j = 4 'Coloque aqui a quantidade de intervalos que vai usar

        ReDim intervalo(1 To j) As Range
        ReDim destin(1 To j) As Range
       
        Set intervalo(1) = Range("H5:I7") 'Para cada novo intervalo, repita essa linha, e aumente um numero no contador do intervalo
        Set intervalo(2) = Range("H9:I11") 'Para cada novo intervalo, repita essa linha, e aumente um numero no contador do intervalo
        Set intervalo(3) = Range("K5:L7") 'Para cada novo intervalo, repita essa linha, e aumente um numero no contador do intervalo
        Set intervalo(4) = Range("K9:L11") 'Para cada novo intervalo, repita essa linha, e aumente um numero no contador do intervalo

        Set destin(1) = Range("C13") 'coloque aqui a célula correspondente ao intervalo
        Set destin(2) = Range("C15") 'coloque aqui a célula correspondente ao intervalo
        Set destin(3) = Range("C17") 'coloque aqui a célula correspondente ao intervalo
        Set destin(4) = Range("C19") 'coloque aqui a célula correspondente ao intervalo

        For i = 1 To j
            If Not Intersect(ActiveCell, intervalo(i)) Is Nothing Then GoTo DISTRIBUIR
        Next i
        Exit Sub

DISTRIBUIR:

        qtd = 3 'digite aqui a quantidade de dígitos que quer considerar

        k = destin(i).Row
        h = destin(i).Column

        valor = Replace(Format(CStr(ActiveCell.Value2), "0.00"), ",", "")

        j = qtd - Len(valor)
        l = qtd
        For i = h To qtd + h
            If i < j Then
                Cells(k, i).ClearContents
            Else
                Cells(k, i).Value2 = Mid(valor, l, 1)
                l = l - 1
                If l <= 0 Then Exit For
            End If
        Next i

        End Sub

Att.

acarloos

 
Postado : 07/02/2015 11:53 am
Página 2 / 2
Forum Jump:
  Tópico Anterior
Próximo Tópico