VBA-Macro to filter date and paste into a new book if it does not exist, and paste into the last filled cell

Asked

Viewed 104 times

2

Good Night, I am New in VBA and I am trying to develop a macro that makes me the following: I have several data in 5 columns and what I want to do is filter through the [E] column and add a new book in csv with the filter name, but if the book already exists then it will paste the data according to the [A] column. ex:macro does filter by column E, copies line 1, 2 to a new book with the name 100, if that book already exists, then it will copy the data and paste in the last filled cell if there are no dates 15/08/2019 or 16/08/2019, if the dates exist then replace the data. What I have so far is the following macro that I found on the internet. If you could help me I’d really appreciate it, thank you.

Sub DistributeRowsToNewWBS()
    Dim wbNew As Workbook
    Dim wsData As Worksheet
    Dim wsCrit As Worksheet
    Dim wsNew As Worksheet
    Dim rngCrit As Range
    Dim LastRow As Long

    Set wsData = Worksheets("Folha1")            ' name of worksheet with the data
    Set wsCrit = Worksheets.Add

    LastRow = wsData.Range("e" & Rows.Count).End(xlUp).Row

    ' column H has the criteria
    wsData.Range("e1:e" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True

    Set rngCrit = wsCrit.Range("A2")
    While rngCrit.Value <> ""
        Set wsNew = Worksheets.Add
        ' change E to reflect columns to copy
        wsData.Range("A1:E" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
        wsNew.Name = rngCrit
        wsNew.Copy
        Set wbNew = ActiveWorkbook
        ' saves new workbook in path of existing workbook
        wbNew.SaveAs ThisWorkbook.Path & "\" & rngCrit
        wbNew.Close SaveChanges:=True
        Application.DisplayAlerts = False
        wsNew.Delete
        rngCrit.EntireRow.Delete
        Set rngCrit = wsCrit.Range("A2")
    Wend

    wsCrit.Delete
    Application.DisplayAlerts = True
End Sub

inserir a descrição da imagem aqui

No answers

Browser other questions tagged

You are not signed in. Login or sign up in order to post.