Olá Pessoal me enviaram este código abaixo para realizar um filtro de datas por período mas não consegui fazer ele rodar. Está ocorrendo erro nas linhas amarelas abaixo. Se alguém puder me ajudar. Grato.
Divino Rodrigues
Private Sub Filtro_de_ Data_ por_Periodo_Click()
Dim DataIni As Date, DataFim as Date, CurrentCell As Range, NextCell As Range
Dim ws As Worksheet, wsRelImpressao As Worksheet, wsBase As Worksheet, RangeOrigem As Range
Dim RangeDestino As Range, x As Integer, LinhaDestino As Integer, ColumnA As Range, FirstBlank As Integer
Set wsBase = ActiveWorkbook.Sheets (ActiveSheet.Name)
If IsDate(TxtDataIni.Value) = True Then
DataIni = TxtDataIni.Value
Else
MsgBox “Digite um valor válido para a Data Inicial!”, vbExclamation, “Felipe Dasi”
TxtDataIni.SetFocus
Exit sub
End if
If IsDate(TxtDataFim.Value) = True Then
DataFim = TxtDataFim.Value
Else
MsgBox “Digite um valor válido para a Data Final!”, vbExclamation, “Felipe Dasi”
TxtDataFim.SetFocus
Exit Sub
End if
Application.DisplayAlerts = False
For Each ws In ActiveWorkbook.Sheets
If Ucase(ws.Name) = “REL IMPRESSAO” Then
ws.Delete
Exit For
End if
Next
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = “REL IMPRESSAO”
Set wsRelImpressao = ActiveWorkbook.Sheets (“REL IMPRESSAO”)
Set ColumnA = ActiveWorkbook.Sheets(“REL IMPRESSAO”).Range(“A:A”)
FirstBlank = Application.CountA(ColumnA)
Set CurrentCell = wsBase.Range(“A4”)
Do While CurrentCell <> “”
x = x +1
if x = 1 then
FirstBlank = Application.CountA(ColumnA)
LinhaDestino = wsRelImpressao.Range(“A1”).Offset(FirstBlank, 0).Row
Set RangeOrigem = wsBase.Range(Cells(CurrentCell.Row, 1).Address, Cells(CurrentCell.Row, Application.Columns.Count).Address
Set RangeDestino = wsRelImpressao.Range(Cells(LinhaDestino, 1).Address, Cells(LinhaDestino, Application.Columns.Count).Address
RangeOrigem.Copy
RangeDestino.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
RangeDestino.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNome, SkipBlanks:=False, Transpose:=False
End if
If IsDate(CurrentCell) = True Then
If CurrentCell >= DataIni And CurrentCell <= DataFim Then
FirstBlank = Application.CountA(ColumnA)
LinhaDestino = wsRelImpressao.Range(“A1”).Offset(FirstBlank, 0).Row
Set RangeOrigem = wsBase.Range(Cells(CurrentCell.Row, 1) .Address, Cells(CurrentCell.Row, Application.Columns.Count).Address
Set RangeDestino = wsRelImpressao.Range(Cells(LinhaDestino, 1).Address, Cells(LinhaDestino, Application.Columns.Count).Address
RangeOrigem.Copy
RangeDestino.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
RangeDestino.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End if
End if
Set NextCell = CurrentCell.Offset (1, 0)
Set CurrentCell = NextCell
Loop
wsRelImpressao.Cells.EntireColumn.AutoFit
wsRelImpressao.Range (“A1”).Select
Unload Me
End sub
