Autofilter (or loop) and copy to another workbook based on Cell Value

Question

I have a master workbook and a few children simply called Master and Child 1 , Child 2 and Child 3 . Data is filled into Master and needs to be sorted, copied and pasted into the relevant child sheet. The destination of all the child workbooks is the Desktop and the filtering required is simply the name of the required workbook in the first column (which also matches the names of each workbook).

I have attempted this task with the below code, which is what I have been able to pull together from a few places, but with no success. I think, owing to my lack of knowledge, I'm just digging my hole deeper, and the code is beginning to get very long-winded:

Private Sub CommandButton21_Click()
 Dim My_Range As Range
 Dim DestSh As Worksheet
 Dim CalcMode As Long
 Dim ViewMode As Long
 Dim FilterCriteria As String
 Dim CCount As Long
 Dim rng As Range
 Dim strActiveSheet As String
 Dim varCellvalue As String
 Dim fpath As String
 Dim owb As Workbook

varCellvalue = Range("A2").Value
fpath = "C:\Users\User\Desktop\Templates\" & varCellvalue & "".xlsm"
strActiveSheet = ActiveSheet.Name

Set My_Range = Range("A1:U" & LastRow(ActiveSheet))
My_Range.Parent.Select

With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False

My_Range.Parent.AutoFilterMode = False

My_Range.AutoFilter Field:=1, Criteria1:="=User 1"

Set owb = Application.Workbooks.Open(fpath)
Set DestSh = Workbooks(" & varCellvalue & ").Sheets("Work")

CCount = 0
On Error Resume Next
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
    MsgBox "There are more than 8192 areas:" _
         & vbNewLine & "It is not possible to copy the visible data." _
         & vbNewLine & "Tip: Sort your data before you use this macro.", _
           vbOKOnly, "Copy to worksheet"
Else
    With My_Range.Parent.AutoFilter.Range
        On Error Resume Next

        Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
                  .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not rng Is Nothing Then

            rng.Copy
            With DestSh.Range("A" & LastRow(DestSh) + 1)
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With
            rng.EntireRow.Delete
        End If
    End With
End If
My_Range.Parent.AutoFilterMode = False

'Restore ScreenUpdating, Calculation, EnableEvents, ....
ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("A1")
With Application
    .Calculation = xlCalculationAuto
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = CalcMode
    .Calculation = xlCalculationAutomatic
End With
Worksheets(strActiveSheet).Activate

End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlValues, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
    On Error GoTo 0
End Function

Example data:

Workbook        Requested by ID  Date Raised
--------------  ---------------  -----------
Child 1    Ben        10000586       01/01/2015
Child 2    John       10000587       02/02/2015
Child 1    Jack       10000588       03/03/2015
Child 2    Percy      10000589       04/04/2015
Child 1    Jill       10000590       05/05/2015
Child 3    George     10000591       06/06/2015

Answer 1

This is a bit more generic - it will recognize any name in column A

In summary:

• Create a new file
• Get unique values from column A, initial file

• While iterating over all items

  • AutoFilter data
  • copy visible range to the new file
  • save the file (and its sheet) with current item name, in current path
  • move to next item

• Clean up and restore all settings

---

Option Explicit

Public Sub splitMaster()
    Dim ws As Worksheet, ur As Range, lr As Long, lc As Long, cel1 As Range
    Dim itms As Variant, itm As Variant, thisPath As String, newWs As Worksheet

    If ws Is Nothing Then Set ws = ThisWorkbook.ActiveSheet
    Set ur = ws.UsedRange

    'if UsedRange contains more than 1 row
    If ur.Row + ur.Rows.Count > 2 Then
        thisPath = ThisWorkbook.Path & "\"  'get path of current file

        enableXl False  'disables ScreenUpdating, Events, and Alerts

        itms = getDistinct(ws, 1)   'removes duplicates and sorts items (col 1)

        'determine last row and column on current sheet, based on UsedRange
        lr = ws.Cells(ur.Row + ur.Rows.Count + 1, ur.Column).End(xlUp).Row
        lc = ws.Cells(ur.Row, ur.Column + ur.Columns.Count + 1).End(xlToLeft).Column

        'turn on Autofilter if it's off
        If ws.AutoFilter Is Nothing Then ur.AutoFilter

        Set newWs = getNewSheet 'creates a new Workbook with a single sheet

        For Each itm In itms    'for each item in column 1 (names)

            'AutoFilter UsedRange based on (exact) value of itm
            ur.Columns(1).AutoFilter Field:=1, Criteria1:=itm   'or: "*" & itm & "*"

            'if there are any visible rows besides the header, continue
            If ur.SpecialCells(xlCellTypeVisible).Count > lc Then

                ur.Copy 'copy visible range (implied)

                Set cel1 = newWs.Cells(ur.Row, ur.Column)   'cell to copy to
                '(this is in new Workbook.Worksheet)

                cel1.PasteSpecial xlPasteColumnWidths   'get column widths
                cel1.PasteSpecial xlPasteAll   'get vals, formulas, cell & font formats

                cel1.Select 'save file with 1st cell selected (instead of paste area)
                newWs.Name = itm    'rename the sheet in the new file to current item

                newWs.Parent.SaveAs thisPath & itm  'save the file

                'delete all data, to prepare the sheet for the next iteration
                newWs.UsedRange.Columns(ur.Column).EntireRow.Delete
            End If
        Next

        newWs.Parent.Close False    'close the new file
        '(which was re-used to save several previous children)

        ur.AutoFilter   'remove the AutoFilter on initial file

        'go to the first cell in initial file, after and copy operations
        Application.Goto ur.Cells(ur.Row, ur.Column)

        enableXl True   'enables ScreenUpdating, Events, and Alerts

        ThisWorkbook.Saved = True   'there were no changes made to initial file
        '(to skip "Save Changes" confirmation)

    End If
End Sub

Public Sub enableXl(ByVal opt As Boolean)   'turns 3 Excel settings on\off
    Application.ScreenUpdating = opt
    Application.EnableEvents = opt
    Application.DisplayAlerts = opt
End Sub

Public Function getNewSheet() As Worksheet
    Dim wb As Workbook, totalNewSheets As Long

    totalNewSheets = Application.SheetsInNewWorkbook  'remember current Excel setting
    Application.SheetsInNewWorkbook = 1               'change setting to 1 sheet
    Set wb = Application.Workbooks.Add                'create the new file
    Application.SheetsInNewWorkbook = totalNewSheets  'restore initial setting
    Set getNewSheet = wb.Worksheets(1)                'return new sheet to calling sub
End Function

'Returns a 2D array (rng) of unique values extracted from colID, sorted a-z
Public Function getDistinct(Optional ByRef ws As Worksheet = Nothing, _
                            Optional ByVal colID As Long = 0) As Variant

    Dim lr As Long, lc As Long, ur As Range, tmp As Range

    'if the optional parameter (sheet) was not provided, use the active sheet
    If ws Is Nothing Then Set ws = ThisWorkbook.ActiveSheet
    Set ur = ws.UsedRange

    'if optional column # parameter was not provided, use the 1st column in used range
    If colID < ur.Column And colID > ur.Columns.Count Then colID = ur.Column

    'determine last row and last column un UsedRange
    lr = ws.Cells(ur.Row + ur.Rows.Count + 1, ur.Column).End(xlUp).Row
    lc = ws.Cells(ur.Row, ur.Column + ur.Columns.Count + 1).End(xlToLeft).Column

    'set the temporary rng variable to the 1st empty column on current sheet
    Set tmp = ws.Range(ws.Cells(ur.Row, lc + 1), ws.Cells(lr, lc + 1))

    If tmp.Count > 1 Then   'if data to be processed contains more than 1 item continue

        'set first cell in the new col to get the (trimmed) value from processed col
        With tmp.Cells(1, 1)
            .Formula = "=Trim(" & ws.Cells(ur.Row, colID).Address(False) & ")"
            'copy the formula down to the last row
            .AutoFill Destination:=tmp
        End With

        'convert formulas to values
        tmp.Value2 = tmp.Value2

        'remove duplicates in the new column only
        tmp.RemoveDuplicates Columns:=1, Header:=xlNo

        'reset the last row
        lr = ws.Cells(ur.Row + ur.Rows.Count + 1, lc + 1).End(xlUp).Row

        'setup the sort (new column only)
        With ws.Sort
            'sort object belongs to the sheet, but sorted field is our new column
            .SortFields.Add Key:=ws.Cells(lr + 1, lc + 1), Order:=xlAscending

            'the actual sorted range is also our new column
            .SetRange tmp

            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .Apply
        End With

        'reset the tmp variable to contain only the distinct (and sorted) values
        Set tmp = ws.Range(ws.Cells(ur.Row, lc + 1), ws.Cells(lr, lc + 1))
    End If

    'return the new items
    getDistinct = tmp       'VBA does not exit the function with this assignment

    'remove the temporary column
    tmp.Cells(1, 1).EntireColumn.Delete

End Function

'--------------------------------------------------------------------------------------

---

It saves all child files in the same location as the master