none
Filtro de Datas por Periodo RRS feed

  • Pergunta

  • 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

     

      

        

       

    quinta-feira, 19 de dezembro de 2019 11:28

Todas as Respostas

  • DIVINORS,

        Parece que faltou fechar um parênteses no final da linha. Veja:

    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)

    []'s,
    Fabio I.
    quinta-feira, 19 de dezembro de 2019 14:39
  • Fabio

    Muito obrigado! Consegui utilizar o código após a sua intervenção. Valeu!!!!

    Cordialmente

    Divino Rodrigues

    sexta-feira, 20 de dezembro de 2019 11:30
  • DIVINORS, fico feliz por você ter conseguido, mas por favor, me pontue como a melhor resposta, obrigado!
    sexta-feira, 20 de dezembro de 2019 11:42