VBA Auto Filter and Paste to Create New Sheets.

[paulcherianc]

I have drafted a macro to automate my excel.


1. Autofilter and create new worksheets based on the filter value with keeping the same format of the original file.
2. AutoFill Destination Range("A5: A6") to the end of the column.
3. Loop the process until the filter fields get over.
4. Filter Range will vary. (Range("C4:AT12").Select)). So macro should find the end of the range automatically.


Unfortunately, the macro is not copying the range I need to Paste on the newly created sheets.
My filter Row Range is from A6 till AT6. The range I need to copy to new sheets starts from C4 till AT and end of the range.



Can any one help me to fix this?


Thanks in advance!

Sub AutoFilterAndCreateNewSheets()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As String


'specify sheet name in which the data is stored
sht = "Timesheet"


'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Sheets(sht).Range("A6:AT" & last)


Sheets(sht).Range("A6:A" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("XFD1"), Unique:=True


For Each x In Range([XFD2], Cells(Rows.Count, "XFD").End(xlUp))


With rng
.AutoFilter
.AutoFilter Field:=1, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy


Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
ActiveSheet.Paste
End With
Next x


' Turn off filter
Sheets(sht).AutoFilterMode = False


With Application
.CutCopyMode = False
.ScreenUpdating = True
End With


End Sub

 

[JackDanIce]

Tested on a dummy workbook and works, turn off any filtering before running, then try:

Sub Macro1()
    
    Dim x       As Long
    Dim y       As Long
    
    Dim dic     As Object
    Dim arr()   As Variant
    Dim var     As Variant
    Dim rng     As Range
    
    Set dic = CreateObject("Scripting.Dictionary")
    y = Range("AT1").Column


    Application.ScreenUpdating = False

    With Sheets("Timesheet")
        arr = .Cells(6, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).row - 5, y).Value
    
        For x = LBound(arr, 1) To UBound(arr, 1)
            Set rng = .Cells(x + 5, 1).Resize(, y)
            If dic.exists(arr(x, 1)) Then Set rng = Union(dic(arr(x, 1)), rng)
            Set dic(arr(x, 1)) = rng
        Next x
    End With
    
    Erase arr
    Set rng = Nothing
    
    For Each var In dic
        Sheets.add(after:=Sheets(Sheets.Count)).Name = CStr(var)
        With Sheets(CStr(var))
            dic(var).Copy
            .Cells(1, 1).PasteSpecial xlPasteAll
            Application.CutCopyMode = False
        End With
    Next var
    
    Application.ScreenUpdating = True
    
    Set dic = Nothing
    
End Sub

 

[paulcherianc]

Just added: .Offset(-2, 2).Resize(rng.Rows.Count + 2, rng.Columns.Count - 2) and fixed it. Thanks!

.Offset(-2, 2).Resize(rng.Rows.Count + 2, rng.Columns.Count - 2).SpecialCells(xlCellTypeVisible).Copy