Adicionar condição na geração de relatório

2024 - VBA & Macros

Post Recente por GuiLivramento 2 anos atrás

1 Posts

1 Usuários

0 Reactions

775 Visualizações

RSS

GuiLivramento

(@guilivramento)

Posts: 2

New Member

Topic starter

Boa noite !!!

Estou com a seguinte dúvida. Gostaria de adicionar a 3 condições para a geração do relatório a seguir, quando marcado a opção a compensar ele retorne os valores do relatório porém filtrando somente os apontados na coluna L como "a compensar", se marcado a opção compensado retorne os apontados como "compensado" e se ambos estiverem marcados retornem os dois valores.

Segue o código do relatório:

Private Sub CommandButton1_Click()


Sheets("RELATÓRIO POR VENCIMENTO").Select


If Range("B2").Value <> "" Then



'código de limpeza


Sheets("RELATÓRIO POR VENCIMENTO").Select

ActiveSheet.Unprotect


Range("Tabela4[[#Headers],[DATA ]]").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range("B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    Range("B2:L2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
       
    
    Range("E1:L1").Select
    Selection.ClearContents



'código do relatorio


Range("E1:L1").Select
    ActiveCell.FormulaR1C1 = "VENCIMENTOS ENTRE " & PERIODO1.Value & " E " & PERIODO2.Value & " "


Cells(41, 13) = "VENCIMENTO"
Cells(42, 13) = ">=" & PERIODO1.Value



Cells(41, 14) = "VENCIMENTO"
Cells(42, 14) = "<=" & PERIODO2.Value



   Dim CO As Variant              'Guarda os Critérios Originais para repô-los ao final
   Dim d1 As String, d2 As String 'd1 e d2 = Data sem comparador
   Dim r1 As String, r2 As String 'r1 e r2 = comparadores relacionais de T2 e U2
   CO = Array([M42].Value, [N42].Value)
   d1 = Replace(Replace(Replace(CO(0), ">", ""), "<", ""), "=", ""): r1 = Replace(CO(0), d1, "")
   d2 = Replace(Replace(Replace(CO(1), ">", ""), "<", ""), "=", ""): r2 = Replace(CO(1), d2, "")
   Application.ScreenUpdating = False
     If IsDate(d1) Then [M42].Value = r1 & Format(d1, "mm/dd/yyyy")
     If IsDate(d2) Then [N42].Value = r2 & Format(d2, "mm/dd/yyyy")
     Sheets("BOLETOS").Range("BOLETOS[#All]").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
            "M41:N42"), CopyToRange:=Range("B2:L2"), Unique:=False
     Range("M42:N42").Value = CO
   Application.ScreenUpdating = True
   
   
   Dim linha As Long
linha = 2

While Cells(linha, 2).Value <> ""

linha = linha + 1

Wend

linha = linha - 1

Range("B2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$B$2:$L$" & linha), , xlYes).Name = _
"Tabela4"
Range("Tabela4[#All]").Select
ActiveSheet.ListObjects("Tabela4").TableStyle = "TableStyleLight9"

ActiveWindow.SmallScroll Down:=-39
   
   
    
    
    
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
   
    Range("Tabela4[[#Headers],[DATA ]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("D25").Select
    ActiveWindow.SmallScroll Down:=-51
    Range("B3").Select
      
    
    
    
    
        
        
        
    Range("M41:N42").Select
    Selection.ClearContents
    
    
    
    
    
    ActiveSheet.Protect
    
    ActiveWorkbook.Save
    
    Unload MENUGERARRELATORIO



Else



'codigo do relatorio


Sheets("RELATÓRIO POR VENCIMENTO").Select

ActiveSheet.Unprotect


Range("E1:L1").Select
    ActiveCell.FormulaR1C1 = "VENCIMENTOS ENTRE " & PERIODO1.Value & " E " & PERIODO2.Value & " "


Cells(41, 13) = "VENCIMENTO"
Cells(42, 13) = ">=" & PERIODO1.Value



Cells(41, 14) = "VENCIMENTO"
Cells(42, 14) = "<=" & PERIODO2.Value



   
   
   CO = Array([M42].Value, [N42].Value)
   d1 = Replace(Replace(Replace(CO(0), ">", ""), "<", ""), "=", ""): r1 = Replace(CO(0), d1, "")
   d2 = Replace(Replace(Replace(CO(1), ">", ""), "<", ""), "=", ""): r2 = Replace(CO(1), d2, "")
   Application.ScreenUpdating = False
     If IsDate(d1) Then [M42].Value = r1 & Format(d1, "mm/dd/yyyy")
     If IsDate(d2) Then [N42].Value = r2 & Format(d2, "mm/dd/yyyy")
     Sheets("BOLETOS").Range("BOLETOS[#All]").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
            "M41:N42"), CopyToRange:=Range("B2:L2"), Unique:=False
     Range("M42:N42").Value = CO
   Application.ScreenUpdating = True
   
   
  
linha = 2

While Cells(linha, 2).Value <> ""

linha = linha + 1

Wend

linha = linha - 1

Range("B2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$B$2:$L$" & linha), , xlYes).Name = _
"Tabela4"
Range("Tabela4[#All]").Select
ActiveSheet.ListObjects("Tabela4").TableStyle = "TableStyleLight9"

ActiveWindow.SmallScroll Down:=-39
   
   
       
    
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
   
    Range("Tabela4[[#Headers],[DATA ]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("D25").Select
    ActiveWindow.SmallScroll Down:=-51
    Range("B3").Select
         
    
    
        
        
        
    Range("M41:N42").Select
    Selection.ClearContents
    
    
    
    
    
    ActiveSheet.Protect
    
    ActiveWorkbook.Save
    
    Unload MENUGERARRELATORIO




End If



End Sub

Me perdoem caso tenha desrespeitado alguma norma de postagem.

Deus abençoe a todos.

MENU.jpg

Postado : 14/07/2022 9:03 pm