Notifications
Clear all
2024 - VBA & Macros
1
Posts
1
Usuários
0
Reactions
811
Visualizações
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.
Postado : 14/07/2022 9:03 pm