none
Autofilter, copy, paste to new file RRS feed

  • Question

  • Hello,

    Can anyone help me with some code that can autofilter, copy, and paste to a new sheet that is named after the filtered field? 

    Row 1 has column headers and column A contains the unique values (Names) that I want to filter by. There will be multiple rows containing each names.

    I don't know all of the unique values that could be in column A. Is there a way to write the code to make the macro filter each unique value without knowing what those values are?

    I also need it to create a new file and name the file after the unique value (name) from column A.

    Next, it would need to copy the filtered data and paste it to the newly created file.

    It would need to repeat this process until each unique data set has been copied to its own file. 

    Thanks for any help.
    Wednesday, March 28, 2018 8:21 AM

All replies

  • Sub SplitDataBase()
        Dim C As Range
        Dim DSh As Worksheet
        Dim ASh As Worksheet
        Dim strName As String
        Dim rngC As Range
        Dim lngKC As Long
        
        'Optional code to select key column
        'Set rngC = Application.InputBox("Select a cell in the key column", Type:=8)
        'lngKC = rngC.Column
        
        'Code to specify key column
        lngKC = 1 'Key Column 1 = A, 2 = B etc.
        
        Application.DisplayAlerts = False
        Application.EnableEvents = False

        Set ASh = ActiveSheet
        Set rngC = ASh.Range("A1").CurrentRegion
        With ASh
            rngC.Columns(lngKC).AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=.Cells(.Rows.Count, lngKC).End(xlUp)(3), Unique:=True
            With .Cells(.Rows.Count, lngKC).End(xlUp).CurrentRegion
                For Each C In .Cells.Offset(1).Resize(.Cells.Count - 1, 1)
                    If C.Value <> "" Then
                        On Error Resume Next
                        Worksheets(C.Value).Delete
                        On Error GoTo 0
                        Set DSh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
                        DSh.Name = C.Value
                        rngC.AutoFilter Field:=lngKC, Criteria1:=C.Value & "*"
                        rngC.SpecialCells(xlCellTypeVisible).Copy DSh.Range("A1")
                        rngC.AutoFilter
                        DSh.Cells.EntireColumn.AutoFit
                    End If
                Next C
                .Clear
            End With
        End With
        
        If MsgBox("Export the new sheets to files?", vbYesNo) = vbYes Then
            For Each DSh In ActiveWorkbook.Worksheets
                If DSh.Name <> ASh.Name Then
                    DSh.Move
                    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Workbook " & ActiveSheet.Name & ".xlsx"
                    ActiveWorkbook.Close
                End If
            Next DSh
        End If

        Application.DisplayAlerts = True
        Application.EnableEvents = True
        
    End Sub
    Wednesday, March 28, 2018 2:54 PM
  • Thanks you!

    I would like tot take it one step further :)

    I have 2 sheets, in each sheet I want to do the same thing (as mention before) and filter by the same name in both sheets, than copy those 2 sheets to another workbook and save it in that name. and than loop for all.

    How Can I add another sheet to that code?

    Thanks in advance.
    Limor

    Sunday, April 1, 2018 7:56 AM
  • If you have only two sheets to start, then run it as is.

    If you have more that that, then for the two sheets named Sheet1 and Sheet2 - delete this line:

        For Each ASh In Worksheets

    and un-comment this line (and change to the actual sheet names)

        'For Each ASh In Worksheets(Array("Sheet1", "Sheet2"))

    Sub SplitDataBase2()
        Dim C As Range
        Dim DSh As Worksheet
        Dim ASh As Worksheet
        Dim strName As String
        Dim rngC As Range
        Dim lngKC As Long
        Dim boolCopyHeaders As Boolean

        'Optional code to select key column
        'Set rngC = Application.InputBox("Select a cell in the key column", Type:=8)
        'lngKC = rngC.Column

        'Code to specify key column
        lngKC = 1 'Key Column 1 = A, 2 = B etc.

        Application.DisplayAlerts = False
        Application.EnableEvents = False



        For Each ASh In Worksheets

        'For Each ASh In Worksheets(Array("Sheet1", "Sheet2"))

           Set rngC = ASh.Range("A1").CurrentRegion
            With ASh
                rngC.Columns(lngKC).AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=.Cells(.Rows.Count, lngKC).End(xlUp)(3), Unique:=True
                With .Cells(.Rows.Count, lngKC).End(xlUp).CurrentRegion
                    For Each C In .Cells.Offset(1).Resize(.Cells.Count - 1, 1)
                        If C.Value <> "" Then
                            For Each DSh In Worksheets
                                If DSh.Name = C.Value Then
                                    boolCopyHeaders = False
                                    GoTo SheetExists
                                End If
                            Next DSh
                            boolCopyHeaders = True
                            Set DSh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
                            DSh.Name = C.Value
    SheetExists:
                            rngC.AutoFilter Field:=lngKC, Criteria1:=C.Value & "*"
                            rngC.Offset(IIf(boolCopyHeaders, 0, 1)).SpecialCells(xlCellTypeVisible).Copy
                            DSh.Cells(DSh.Rows.Count, "A").End(xlUp).Offset(IIf(boolCopyHeaders, 0, 1)).PasteSpecial xlPasteAll
                            rngC.AutoFilter
                            DSh.Cells.EntireColumn.AutoFit
                        End If
                    Next C
                    .Clear
                End With
            End With
        Next ASh

        If MsgBox("Export the new sheets to files?", vbYesNo) = vbYes Then
            For Each DSh In ActiveWorkbook.Worksheets
                If DSh.Name <> ASh.Name Then
                    DSh.Move
                    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Workbook " & ActiveSheet.Name & ".xlsx"
                    ActiveWorkbook.Close
                End If
            Next DSh
        End If

        Application.DisplayAlerts = True
        Application.EnableEvents = True

    End Sub

                                        
    Monday, April 2, 2018 8:50 PM