Filtering and copy pasting to new workbooks

noelleburr · Jan 10th 2021

Hi,

I need to filter a column and copy paste results into a new workbook until all unique values in that column has been filtered for. I am receiving a 'subscript out of range' error on this line:

Code

last = Workbk.Sheets(sht).Cells(Rows.Count, "L").End(xlUp).Row

This is the full code:

(I saved this code in my personal workbook and would like to run it on the active workbook)

Code

Sub Filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook

sht = "Sheet1"


Set Workbk = ThisWorkbook


last = Workbk.Sheets(sht).Cells(Rows.Count, "L").End(xlUp).Row

With Workbk.Sheets(sht)
Set rng = .Range("A1:L" & last)
End With

Workbk.Sheets(sht).Range("L1:L" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True


For Each x In Workbk.Sheets(sht).Range([AA2], Cells(Rows.Count, "AA").End(xlUp))

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


Set newBook = Workbooks.Add(xlWBATWorksheet)

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


newBook.SaveAs x.Value & ".xlsx"


newBook.Close SaveChanges:=False

Next x


Workbk.Sheets(sht).AutoFilterMode = False

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

End Sub

Display More

**Carim** · Jan 10th 2021

Hi,

You could replace the instruction :

Set Workbk = ThisWorkbook

by

Set Workbk = ActiveWorkbook

Hope this will help

**royUK** · Jan 10th 2021

You need to understand the difference.

ActiveWorkBook is the workbook that is active when the code runs.

ThisWorkBook is the workbook that holds the code.

noelleburr · Jan 10th 2021

Realised my mistake with ActiveWorkBook shortly after posting my code there. I seem to have a couple other issues though. I have data from Column A to BD on my source file, where I need to filter through Column L and copy the results from Column A to BD to a new workbook, and repeat for each unique value in Column L. It is not working as I am hoping for at the moment.

**Carim** · Jan 10th 2021

Glad to hear you have made some progress ..

As far as your initial objective of 'Exploding Unique items', you should be posting a tiny sample file ...

**Carim** · Jan 10th 2021

Your question reminded me of a very similar thread ...

Specific range of data copy from one sheet to another sheets.

**royUK** · Jan 10th 2021

Are you wanting a sheet for each unique value?

noelleburr · Jan 10th 2021

Hi Roy, I need a new workbook for each unique value..

noelleburr · Jan 10th 2021

This is code from the recorded macro, though I am looking for cleaner code that loops through all the unique values from the column to be filtered, hence my attempt at the code posted above.

Code

Rows("1:1").Select
    Range("L1").Activate
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$BD$1474").AutoFilter Field:=12, Criteria1:= _
        "Business"
    Cells.Select
    Range("E1").Activate
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ChDir "C:\Users\t1001\Desktop"
    ActiveWorkbook.SaveAs Filename:="C:\Users\t1001\Desktop\Business.xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

Display More

**royUK** · Jan 10th 2021

Try this. It currently assumes the column with the values in is 3. You will need to amend for your use.

It saves the new workbooks to a subfolder in the same directory as the master workbook.

I can provide code to browse for the destination folder if required, or you can hard code a different path

Code

'Move to workbooks

Option Explicit

Sub ExtractToSheets()
    Dim ws As Worksheet, wsNew As Worksheet
    Dim rData As Range, rCl As Range
    Dim sNm As String
   Const iCol As Integer = 3 ''///- currently uses Column 3
    
    Set ws = Sheet1    '/// you may need to change this
    
    '///extract a list of unique names
    '///first clear existing list
    With ws
        Set rData = .Range("A1").CurrentRegion
        .Columns(.Columns.Count).Clear
        rData.Columns(iCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
        
        For Each rCl In .Cells(1, .Columns.Count).CurrentRegion
            sNm = rCl.Text
            '///add new sheet (only if required-NB uses UDF below)
            If WksExists(sNm) Then
                '///so clear contents
                Sheets(sNm).Cells.Clear
            Else
                '///new sheet required
                Set wsNew = Sheets.Add
                With wsNew
                    .Name = sNm
                    '///AutoFilter & copy to relevant sheet
                    rData.AutoFilter Field:=iCol, Criteria1:=sNm ''/// currently filters column 3
                    rData.Copy Destination:=.Cells(1, 1)
                    .Move
                    '/// saves to a folder in the master workbook's directory
                    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\New Folder Name" & sNm, _
                    FileFormat:=51, CreateBackup:=False
                    ''///close and save new workbook
                    ActiveWorkbook.Close True
                End With
            End If
        Next rCl
    End With
    '\\\tidy up
    ws.Columns(Columns.Count).ClearContents        'remove temporary list
    rData.AutoFilter        'switch off AutoFilter
End Sub


Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Display More

noelleburr · Jan 10th 2021

Hi Roy,

I am getting an error in this line, have changed it to 12 as that is the column I need filtered.

Code

rData.Columns(12).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True

**royUK** · Jan 10th 2021

What error are you getting?

If you want to attach a small example workbook I'll take a look.

I'll be unavailable for an hour or so, but I'll check back later.

If you and all users are using Microsoft 365 then we can update that line.

**Carim** · Jan 10th 2021

Hello again,

Have you tested

Code

Sub ExplodeData()
Dim lr As Long
Dim ws As Worksheet
Dim vcol As Integer
Dim i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' *** Adjust the next three instructions to your situation: '
' ws should show the name of your Data Worksheet '
' title should show the columns from your Data worksheet '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


'''''''''''''''''''''''''
vcol = 12               ' Column L
Set ws = Sheets("Data") ' Define the Source Worksheet
title = "A1:BD1"        ' Define the Headers Range
'''''''''''''''''''''''''


Application.ScreenUpdating = False
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Cells(1, Application.Columns.Count).End(xlToLeft).Column + 1
ws.Cells(1, icol) = "Unique"


 For i = 2 To lr
 On Error Resume Next
 If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
 ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
 End If
 Next i
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
 For i = 2 To UBound(myarr)
 ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
 If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
 Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
 Else
 Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
 End If
 ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
 Sheets(myarr(i) & "").Columns.AutoFit
 Next i
ws.AutoFilterMode = False
ws.Activate
MsgBox " DONE ... !!! "
End Sub

Display More

Hope this will help

P.S. This will create your Individual sheets ... Then it is pretty easy to create a New Workbook for each New Worksheet ...

**Carim** · Jan 10th 2021

Once all your individual sheets are generated by the Explode macro ...

you can create workbooks for each worksheet as follows :

Code

Sub CreateWorkbooks()
Dim Sourcewb As Workbook
Dim Destinwb As Workbook
Dim wsht As Worksheet

Application.ScreenUpdating = False
Set Sourcewb = ActiveWorkbook
    For Each wsht In Sourcewb.Worksheets
    ' Adjust the Sheet Name to be excluded
        If wsht.Name <> "Data" Then
            wsht.Copy
            Set Destinwb = ActiveWorkbook
            Destinwb.SaveAs ThisWorkbook.Path & "\" & wsht.Name, FileFormat:=52
            Destinwb.Close
        End If
    Next wsht
Application.ScreenUpdating = True
End Sub

Display More

Hope this will help

**Carim** · Jan 10th 2021

Once you have tested the macros ... feel free to share your comments ...

noelleburr · Jan 11th 2021

Hi Carim, just tried it and it works perfectly. The CopyToRange line wasn't working for me but copying to sheets first works out better. Thank you!

**Carim** · Jan 11th 2021

Quote from noelleburr

Hi Carim, just tried it and it works perfectly. The CopyToRange line wasn't working for me but copying to sheets first works out better. Thank you!

Glad to hear you could sort it out

Thanks for your Thanks !!!

**royUK** · Jan 11th 2021

My code copies to sheets then moves the sheet to a new workbook. Maybe you could answer my questions about the error, this has been working for many years.

noelleburr · Jan 11th 2021

Hi Roy, I just tried running your code and it is working fine! Although I could not recall what the error was. Must've been a careless mistake somewhere on my part. Thanks for following up

**royUK** · Jan 12th 2021

I was surprised, I have been using that code for years.

Filtering and copy pasting to new workbooks

Participate now!

Share