Modificação de códi...
 
Notifications
Clear all

Modificação de código

14 Posts
1 Usuários
0 Reactions
1,226 Visualizações
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Senhores,boa tarde.
Por gentileza, gostaria de pedir que me ajudem.
Trata se do segunte:
Estou tentando,porém, sem sucesso algum alterar o código abaixo.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim LLoop As Integer
    
    Dim LTargetRange1 As String
    Dim LDestRange1 As String
    Dim LTargetRange2 As String
    Dim LDestRange2 As String
    Dim LTargetRange3 As String
    Dim LDestRange3 As String
    LLoop = 2
    While LLoop <= 1000
        'Link coluna A to B
        LTargetRange1 = "A" & CStr(LLoop)
        LDestRange1 = "c" & CStr(LLoop)
        LTargetRange2 = "A" & CStr(LLoop)
        LDestRange2 = "D" & CStr(LLoop)
        LTargetRange3 = "A" & CStr(LLoop)
        LDestRange3 = "E" & CStr(LLoop)
        
        If Not Intersect(Range(LTargetRange1), Target) Is Nothing Then
            If Len(Range(LTargetRange1).Value) > 0 Then
                Range(LDestRange1).Value = Date
            Else
                Range(LDestRange1).Value = Null
            End If
        End If
       If Not Intersect(Range(LTargetRange2), Target) Is Nothing Then
            If Len(Range(LTargetRange2).Value) > 0 Then
                Range(LDestRange2).Value = Date
            Else
                Range(LDestRange2).Value = Null
            End If
        End If
        
      If Not Intersect(Range(LTargetRange3), Target) Is Nothing Then
            If Len(Range(LTargetRange3).Value) > 0 Then
                Range(LDestRange3).Value = Date
            Else
                Range(LDestRange3).Value = Null
            End If
        End If
        
        LLoop = LLoop + 1
    Wend
    
End Sub

O propósito dessa rotina é colocar as data nas colunas (C,D,E). Porém, o que eu gostaria mesmo é de formatar as mesmas na seguinte ordem: Dia,Mês,Ano.
E, fazer também com que na leitura desse código fosse reconhecido sempre a última linha. Aplicando a condição LLoop = 2
While LLoop <= 1000 sua leitura se torna lenta e pesada. Na verdade essas datas deverão ser atribuídas de acorno com o volume de dados.
Grato a todos mais uma vez.
PAYZZANNO

 
Postado : 07/03/2013 2:13 pm
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Boa noite!!

Eu não tive problema com a data, mas mesmo alterei.

Veja se te ajuda.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim LLoop As Integer
    
    Dim LTargetRange1 As String
    Dim LDestRange1 As String
    Dim LTargetRange2 As String
    Dim LDestRange2 As String
    Dim LTargetRange3 As String
    Dim LDestRange3 As String
    Dim yourdate As String
    Dim lngLastRow As Long
    
    yourdate = Format(Date, "dd-mm-yyyy")
    lngLastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    LLoop = 2
    While LLoop <= lngLastRow
        'Link coluna A to B
        LTargetRange1 = "A" & CStr(LLoop)
        LDestRange1 = "c" & CStr(LLoop)
        LTargetRange2 = "A" & CStr(LLoop)
        LDestRange2 = "D" & CStr(LLoop)
        LTargetRange3 = "A" & CStr(LLoop)
        LDestRange3 = "E" & CStr(LLoop)
        
        If Not Intersect(Range(LTargetRange1), Target) Is Nothing Then
            If Len(Range(LTargetRange1).Value) > 0 Then
                Range(LDestRange1).Value = yourdate
            Else
                Range(LDestRange1).Value = Null
            End If
        End If
       If Not Intersect(Range(LTargetRange2), Target) Is Nothing Then
            If Len(Range(LTargetRange2).Value) > 0 Then
                Range(LDestRange2).Value = yourdate
            Else
                Range(LDestRange2).Value = Null
            End If
        End If
        
      If Not Intersect(Range(LTargetRange3), Target) Is Nothing Then
            If Len(Range(LTargetRange3).Value) > 0 Then
                Range(LDestRange3).Value = yourdate
            Else
                Range(LDestRange3).Value = Null
            End If
        End If
        
        LLoop = LLoop + 1
    Wend
    
End Sub
 
Postado : 07/03/2013 6:35 pm
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Caro amigo, Alexandrevba, boa tarde. Mais uma vez peço lhe desculpas por minha demora.
A tua modificação ficou ótima. Fiz uma modificação de acordo com minha necessidade e ficou muito boa. E, isso devo a você.
Porém, se não for abuso peço a ti, por gentileza, mais uma ajuda.
Estou expondo o código modificado abaixo para faças uma avaliação e, se possível, me ajude.

Antes de tal exposição observe, por gentileza, minha necessidade.
Ao digitar na primeira coluna gostaria que o cursor pulasse para segunda coluna em seguida para terceira logo após para quarta coluna e ao chegar nessa quarta coluna voltasse para primeira coluna e cumprisse a sequencia de digitação mais uma vez dando seguimento na linha debaixo e assim por diante,

Por gentileza, poderia me ajudar mais uma vez?

Segue o código modificado.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim LLoop As Integer
    Dim LTargetRange1 As String
    Dim LDestRange1 As String
    Dim LTargetRange2 As String
    Dim LDestRange2 As String
    Dim LTargetRange3 As String
    Dim LDestRange3 As String
    Dim yourdate1 As String
    Dim yourdate2 As String
    Dim yourdate3 As String
    Dim lngLastRow As Long
    yourdate1 = Format(Date, "dd")
    yourdate2 = Format(Date, "mmmm")
    yourdate3 = Format(Date, "yyyy")
    lngLastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    LLoop = 2
    While LLoop <= lngLastRow
        'Link coluna A to B
        LTargetRange1 = "A" & CStr(LLoop)
        LDestRange1 = "e" & CStr(LLoop)
        LTargetRange2 = "A" & CStr(LLoop)
        LDestRange2 = "f" & CStr(LLoop)
        LTargetRange3 = "A" & CStr(LLoop)
        LDestRange3 = "g" & CStr(LLoop)
        
        If Not Intersect(Range(LTargetRange1), Target) Is Nothing Then
            If Len(Range(LTargetRange1).Value) > 0 Then
                Range(LDestRange1).Value = yourdate1
            Else
                Range(LDestRange1).Value = Null
            End If
        End If
       If Not Intersect(Range(LTargetRange2), Target) Is Nothing Then
            If Len(Range(LTargetRange2).Value) > 0 Then
                Range(LDestRange2).Value = yourdate2
            Else
                Range(LDestRange2).Value = Null
            End If
        End If
        
      If Not Intersect(Range(LTargetRange3), Target) Is Nothing Then
            If Len(Range(LTargetRange3).Value) > 0 Then
                Range(LDestRange3).Value = yourdate3
            Else
                Range(LDestRange3).Value = Null
            End If
        End If
        
        LLoop = LLoop + 1
    Wend

End Sub

Grato mais uma vez.
PAYZZANNO.

 
Postado : 09/03/2013 10:50 am
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Boa tarde!!

Em uma coluna haverá mais de uma célula, eu pergunto vai saltar para a direita após digitar em uma unica célula? Ou quantas células de uma coluna terá que ser preenchida para seguir para a próxima coluna?

Além disso você pode configurar a tecla enter para que ao ser pressionada vá para a direita, combine isso com as colunas bloqueadas.

Att

 
Postado : 09/03/2013 3:14 pm
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Estou tento aplicar ou unir esta condição ao código,acima, modificado.
Veja por gentileza.

Private Sub Worksheet_Change(ByVal cel As Range)
Dim Lin As Integer
Lin = Range("a65536").End(xlUp).Row
If Lin < 2 Then
Lin = 2
End If

Select Case cel.Address

Case Range("a" & Lin).Address
Range("b" & Lin).Select
Lin = Lin + 1

Case Range("b" & Lin).Address
Range("a" & Lin).Select
Lin = Lin + 1
Range("a" & Lin).Select
End Select
Lin = Lin + 1
End Sub

O caso é que sempre dá erro em: Select Case cel.Address
Esse caso está para duas colunas é fato que modificarei de acordo com o necessário
Grato pela gentileza.
PAYZZANNO

 
Postado : 09/03/2013 9:23 pm
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Bom dia!!

Vamos ver se eu entendi.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
     
    If Target.Cells.Count > 1 Then Exit Sub
     
    Select Case Target.Column
    Case 1, 2, 3, 4
        Cells(Target.Row, Target.Column + 1).Select
         
    Case 5
        Cells(Target.Row + 1, Target.Column - 4).Select
         
    Case Else
        Exit Sub
         
    End Select
     
End Sub

Faça os testes.

Att

 
Postado : 10/03/2013 7:51 am
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Valeu Aledrandrevba.
Era isso mesmo. Não estava conseguindo conciliar as rotinas. A eficácia de teu trabalho é, sem dúvida alguma, invejável.

Deus o abençoe imensamente.

Mais uma vez grato por tua ajuda.
PAYZZANNO

 
Postado : 10/03/2013 3:11 pm
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Boa noite!!

Poxa, agora click na mãozinha :( :(

Att

 
Postado : 10/03/2013 4:29 pm
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Alexandrevba, bom dia.
Me ocorreu uma idéia.
Por gentileza, como ficaria caso eu resolvesse selecionar qualquer coluna independentemente da sequencia?
Diagamos:

Coluna (A),(D),(O)(J) e fianalmente voltando para coluna inicial (A) linha a linha.
Há, por gentileza, como se aplicar tal conceito?
Para não abrir outro tópico estou dando seguimento neste. Achei ser pertinente.

Grato mais uma vez.
PAYZZANNO

 
Postado : 13/03/2013 6:57 am
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Boa tarde!!

Caso alguém não te responda e você poder esperar, eu vou dar uma olhada, mas eu voltei a trabalhar e estou sem tempo, creio que só amanhã pra eu olhar.

Eu estou agora no horário de almoço e já vou voltar para trabalho ai não vai dar tempo de eu ver com atenção. :oops:

Att

 
Postado : 13/03/2013 9:34 am
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Boa noite!!

Eu não entendi, você pretende digitar na Coluna (A), o cursor ir para (D), digitar na D e ir para (O), digitar na O e ir para (J)????

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
     
    If Target.Cells.Count > 1 Then Exit Sub
     
    Select Case Target.Column
    Case 1
        Cells(Target.Row, Target.Column + 3).Select
    Case 4
        Cells(Target.Row, Target.Column + 6).Select
    Case 10
        Cells(Target.Row, Target.Column + 5).Select
    Case 15
        Cells(Target.Row + 1, Target.Column - 14).Select
         
    Case Else
        Exit Sub
         
    End Select
     
End Sub

Att

 
Postado : 13/03/2013 6:55 pm
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Olá alexandrevba .Bom dia. Tenho andado tão ocupado que até esqueci de ti lembrar de minha última observação nesse tópico. Até peço desculpas pela insistência e minha falta de lembrança.

Grato.

 
Postado : 18/03/2013 7:51 am
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Boa tarde!!

Sem problemas, mas faças todos os testes e veja se é isso.
Depois dê retorno!
Att

 
Postado : 18/03/2013 9:37 am
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Oi alexandrevba. Ficou show.
Sem dúvida alguma eficácia pura.
Excelente é a qualidade do teu trabalho.

Muitíssimo obrigado. :D

 
Postado : 18/03/2013 11:40 am