Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Verificar três cond...
 
Notifications
Clear all

[Resolvido] Verificar três condições para validar

 
2024 - VBA & Macros
Post Recente por Mineiro 2 anos atrás
7 Posts
2 Usuários
0 Reactions
1,398 Visualizações
RSS
 Mineiro
(@mineiro)
Posts: 0
Estimable Member
Topic starter
 

Boa tarde!

Gostaria da ajuda de vocês. Estou trabalhando com uma macro (contribuição de uma colega do forum) que insere uma linha abaixo sempre que a resposta for PC ou NC

====

Private Sub Worksheet_Change(ByVal Target As Range)
'O que for digitado na coluna C será escrito em maiúsculo
On Error Resume Next
If Not Intersect(Target, Range("V:V")) Is Nothing Then
Application.EnableEvents = False
Target = UCase(Target)
Application.EnableEvents = True
End If
On Error GoTo 0

'Se na coluna V não estiver digitado NC ou PC não fazer nada
If Target.Column <> 22 Or Target.Text <> "NC" And Target.Text <> "PC" Then Exit Sub
Rows(Target.Row + 1).Insert
Cells(Target.Row + 1, 23).Resize(, 42).Merge
Cells(Target.Row + 1, 23).Select
Cells(Target.Row + 1, 22).ClearContents
End Sub

====

Preciso incorporar a essa macro a seguinte orientação: todas as vezes que em determinado bloco de perguntas aparecer respostas NC ou PC, uma nova linha deve ser inserida ao final do bloco, conforme descrito a seguir. Encaminha uma planilha anexa com a macro e maiores detalhes.

Como deve ser
--------------------
Bloco 1
---------------------
Pergunta 1 = C
Pergunta 2 = NC (Como a resposta foi NC, inserir uma linha abaixo da pergunta 2)
Pergunta 3 = C
Pergunta 4 = C
Pergunta 5 = PC (Como a resposta foi PC, inserir uma linha abaixo da pergunta 5)
(Como neste bloco apareceram respostas PC ou NC, inserir mais uma linha abaixo da pergunta 5)
---------------------
Bloco 2
---------------------
Pergunta 1 = C
Pergunta 2 = C
Pergunta 3 = NC (Como a resposta foi NC, inserir uma linha abaixo da pergunta 3)
(Como neste bloco apareceram respostas PC ou NC, inserir mais uma linha abaixo da pergunta 3)
---------------------
Bloco 3
---------------------
Pergunta 1 = C
Pergunta 2 = PC (Como a resposta foi PC, inserir uma linha abaixo da pergunta 2)
Pergunta 3 = C
Pergunta 4 = C
(Como neste bloco apareceram respostas PC ou NC, inserir uma linha abaixo da pergunta 4)
---------------------

 
_______________________________________________________________________________________________
Editado pela Moderação. Motivo: Procure utilizar o botão Código (< >) sempre que for inserir código VBA ou Fórmulas.
 
Postado : 29/07/2022 4:07 pm
EdsonBR
 EdsonBR
(@edsonbr)
Posts: 1057
Noble Member
 

Boa tarde, @Mineiro

Veja se este código lhe ajuda (substitua o que vc tem lá por este):

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim r As Range, rQPS As Range
  Set Target = Target.Cells(1)
  If Target.Value = "" Or Target.Column <> 22 Then Exit Sub
  If Target.Offset(, -2).MergeCells Then
    Set rQPS = Target.Offset(, -2).MergeArea
    Application.EnableEvents = False
      Target.Value = UCase(Target.Value)
      If Target.Value Like "[NP]C" Then
       Set r = Range(Intersect(Target.EntireRow, Columns("T")), _
                     Intersect(Target.EntireRow, Columns("BL")))
       If r.Row < rQPS.Cells(rQPS.Rows.Count, 1).Row Then
         r.Offset(1).Insert Shift:=xlShiftDown
           Set r = r.Offset(1)
             Range(r.Columns(4), r.Columns(r.Columns.Count)).Merge
               r.Borders.LineStyle = xlContinuous
         Set rQPS = Union(r.Cells(1), rQPS)
           rQPS.Merge
             rQPS.Borders.LineStyle = xlContinuous
       End If
       Set r = Intersect(r.EntireColumn, Rows(rQPS.Cells(rQPS.Rows.Count, 1).Row))
       r.Offset(1).Insert Shift:=xlShiftDown
         Set r = r.Offset(1) 
           Range(r.Columns(4), r.Columns(r.Columns.Count)).Merge
             r.Borders.LineStyle = xlContinuous
       Set rQPS = Union(r.Cells(1), rQPS)
         rQPS.Merge
           rQPS.Borders.LineStyle = xlContinuous
      End If
    Application.EnableEvents = True
  End If
End Sub

 
Postado : 02/08/2022 3:46 pm
 Mineiro
(@mineiro)
Posts: 0
Estimable Member
Topic starter
 

Edson, boa tarde!

Em primeiro lugar, muito obrigado pela sua ajuda e interesse.

Testei o código que você enviou. Falta um pequeno ajuste (eliminar algumas linhas e incluir outras) que eu explico melhor na planilha anexa (ela já está com o código que você desenvolveu).

 

 
Postado : 02/08/2022 4:19 pm
EdsonBR
 EdsonBR
(@edsonbr)
Posts: 1057
Noble Member
 

Veja se agora é isso, @Mineiro

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim r As Range, rQPS As Range, rUL As Range
  Set Target = Target.Cells(1)
  If Target.Value = "" Or Target.Column <> 22 Then Exit Sub
  If Target.Offset(, -2).MergeCells Then
    Set rQPS = Target.Offset(, -2).MergeArea
    Application.EnableEvents = False
      Target.Value = UCase(Target.Value)
      If Target.Value Like "[NP]C" Then
        Set r = Intersect([T:BL], Target.EntireRow)
        Set rUL = Intersect([T:BL], rQPS.Rows(rQPS.Rows.Count).EntireRow)
        InsereCampo r, rQPS
        If (Application.CountA(rUL) > 0) Then InsereCampo rUL, rQPS
      End If
    Application.EnableEvents = True
  End If
End Sub
Private Sub InsereCampo(ByRef r As Range, ByRef rQPS As Range)
       r.Offset(1).Insert Shift:=xlShiftDown
         Set r = r.Offset(1)
           Range(r.Columns(4), r.Columns(r.Columns.Count)).Merge
             r.Borders.LineStyle = xlContinuous
       Set rQPS = Union(r.Cells(1), rQPS)
         rQPS.Merge
           rQPS.Borders.LineStyle = xlContinuous
End Sub

 
Postado : 05/08/2022 9:32 am
 Mineiro
(@mineiro)
Posts: 0
Estimable Member
Topic starter
 

Edson, boa noite! 

Ficou perfeito. Faltou apenas colorir as linhas que são inseridas. É possível?

 
Postado : 05/08/2022 6:31 pm
EdsonBR
 EdsonBR
(@edsonbr)
Posts: 1057
Noble Member
 

Usando as cores que vc usou (ouro ênfase 4/80% e verde ênfase 6/80%):

Private Sub Worksheet_Change(ByVal Target As Range)
  Const ouro = XlThemeColor.xlThemeColorAccent4
  Const verde = XlThemeColor.xlThemeColorAccent6
  Dim r As Range, rQPS As Range, rUL As Range
  Set Target = Target.Cells(1)
  If Target.Value = "" Or Target.Column <> 22 Then Exit Sub
  If Target.Offset(, -2).MergeCells Then
    Set rQPS = Target.Offset(, -2).MergeArea
    Application.EnableEvents = False
      Target.Value = UCase(Target.Value)
      If Target.Value Like "[NP]C" Then
        Set r = Intersect([T:BL], Target.EntireRow)
        Set rUL = Intersect([T:BL], rQPS.Rows(rQPS.Rows.Count).EntireRow)
        InsereCampo r, rQPS, ouro
        If (Application.CountA(rUL) > 0) Then InsereCampo rUL, rQPS, verde
      End If
    Application.EnableEvents = True
  End If
End Sub
Private Sub InsereCampo(ByRef r As Range, ByRef rQPS As Range, corFundo)
       r.Offset(1).Insert Shift:=xlShiftDown
         Set r = r.Offset(1)
          With Range(r.Columns(4), r.Columns(r.Columns.Count))
           .Merge
           .Interior.ThemeColor = corFundo
           .Interior.TintAndShade = 0.8
         End With
             r.Borders.LineStyle = xlContinuous
       Set rQPS = Union(r.Cells(1), rQPS)
         rQPS.Merge
           rQPS.Borders.LineStyle = xlContinuous
End Sub

 

 
Postado : 06/08/2022 12:40 am
 Mineiro
(@mineiro)
Posts: 0
Estimable Member
Topic starter
 

Bom dia, Edson!

Ficou excelente! Exatamente como eu preciso. Muito obrigado!

 
Postado : 06/08/2022 9:16 am
Forum Jump:
  Tópico Anterior
Próximo Tópico