Vídeo recomendado
https://youtu.be/diWPPPhW-9E

Unir funções Worksheet_Change

Fórum para dúvidas sobre os fundamentos da linguagem de programação Visual Basic no contexto do VBA
andril
Acabou de chegar
Acabou de chegar
Mensagens: 9
Registrado em: Sáb Dez 28, 2019 5:23 am

Unir funções Worksheet_Change

Mensagem por andril »

Bom dia rapazes.

Precisava de uma ajuda realmente para um caso em particular, tenho duas funções Worksheet_Change, uma para forçar o formato de data, e outra para forçar as letras em maiúsculas, pesquisando, consegui encontrar uma solução para o mesmo problema, mas como são fórmulas diferentes, não consegui adaptar para o meu caso: https://stackoverflow.com/questions/253 ... eet-change

Os códigos são:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Dim DateStr As String
On Error GoTo EndMacro
If Intersect(Target, Range("C5")) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub

Application.EnableEvents = False
With Target
If .HasFormula = False Then
Select Case Len(.Formula)
Case 4
DateStr = Left(.Formula, 1) & "/" & _
Mid(.Formula, 2, 1) & "/" & Right(.Formula, 2)
Case 5
DateStr = Left(.Formula, 1) & "/" & _
Mid(.Formula, 2, 2) & "/" & Right(.Formula, 2)
Case 6
DateStr = Left(.Formula, 2) & "/" & _
Mid(.Formula, 3, 2) & "/" & Right(.Formula, 2)
Case 7
DateStr = Left(.Formula, 1) & "/" & _
Mid(.Formula, 2, 2) & "/" & Right(.Formula, 4)
Case 8
DateStr = Left(.Formula, 2) & "/" & _
Mid(.Formula, 3, 2) & "/" & Right(.Formula, 4)
Case Else
Err.Raise 0
End Select
.Formula = DateValue(DateStr)
End If
End With
Application.EnableEvents = True
Exit Sub
EndMacro:
MsgBox "Insira: 1120 para 01/01/2020!"
Range(Target.Address).ClearContents
Application.EnableEvents = True
End Sub

E:

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Target.HasFormula Then Target.Value = UCase(Target.Value)
Application.EnableEvents = True
End Sub

Alguém consegue me ajudar com isso? Obrigado a todos.


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Avatar do usuário
Reinaldo
Jedi
Jedi
Mensagens: 1537
Registrado em: Sex Ago 01, 2014 4:09 pm
Localização: Garça - SP / SCS - SP

Re: Unir funções Worksheet_Change

Mensagem por Reinaldo »

Experimente

Código: Selecionar todos

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim DateStr As String

On Error GoTo EndMacro

If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub

Application.EnableEvents = False

If Intersect(Target, Range("C5")) Is Nothing Then
    If Not Target.HasFormula Then Target.Value = UCase(Target.Value)
Else
    With Target
        If .HasFormula = False Then
            Select Case Len(.Formula)
                Case 4
                    DateStr = Left(.Formula, 1) & "/" & _
                    Mid(.Formula, 2, 1) & "/" & Right(.Formula, 2)
                Case 5
                    DateStr = Left(.Formula, 1) & "/" & _
                    Mid(.Formula, 2, 2) & "/" & Right(.Formula, 2)
                Case 6
                    DateStr = Left(.Formula, 2) & "/" & _
                    Mid(.Formula, 3, 2) & "/" & Right(.Formula, 2)
                Case 7
                    DateStr = Left(.Formula, 1) & "/" & _
                    Mid(.Formula, 2, 2) & "/" & Right(.Formula, 4)
                Case 8
                    DateStr = Left(.Formula, 2) & "/" & _
                    Mid(.Formula, 3, 2) & "/" & Right(.Formula, 4)
                Case Else
                Err.Raise 0
            End Select
        .Formula = DateValue(DateStr)
        End If
    End With
End If
Application.EnableEvents = True
Exit Sub
EndMacro:
MsgBox "Insira: 1120 para 01/01/2020!"
Range(Target.Address).ClearContents
Application.EnableEvents = True
End Sub


andril
Acabou de chegar
Acabou de chegar
Mensagens: 9
Registrado em: Sáb Dez 28, 2019 5:23 am

Re: Unir funções Worksheet_Change

Mensagem por andril »

Gênio.

Funciona perfeitamente.

Muito obrigado amigo!!!


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Responder