VBA Help needed - Filter data and save as separate workbook

**krjoshi** · 07-10-2012, 03:28 PM

Hi Folks,

I have a workbook with lot of records; I want a vba code to do filter "C" Column values and save as new workbook in this folder "C:\joshi" Individually based on "C" column cell values.

I have attached an excel file of what I'm trying to accomplish. Thanks in advance for your expertise!

Joshi

**jaslake** · 07-10-2012, 06:37 PM

Hi joshi

Try this in a General Module...let me know of issues.

Option Explicit

Sub Macro1()
    Dim NewBook As Workbook
    Dim MyPath As String
    Dim Rng As Range
    Dim cel As Range
    Dim LR As Long
    Dim LC As Long
    
    Application.ScreenUpdating = False
    MyPath = "C:\joshi"

    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Lists").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Worksheets.Add After:=ActiveSheet
    ActiveSheet.Name = "Lists"
    With Sheets("All_Jobs")
        If Not .AutoFilterMode Then
            .Range("A1").AutoFilter
        End If
        LR = .Range("A" & .Rows.Count).End(xlUp).Row
        LC = .Cells.Find(What:="*", After:=[A1], _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious).Column
        .Columns("C:C").AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=Sheets("Lists").Range("A1"), Unique:=True
        ActiveWorkbook.Names.Add Name:="FLists", RefersTo:= _
                "=OFFSET(Lists!$A$2,0,0,(COUNTA(Lists!$A:$A)-1),1)"
        For Each cel In Range("FLists")
            Set NewBook = Workbooks.Add
            With NewBook
                .SaveAs Filename:=MyPath & "\" & cel.Value & ".xlsx"
            End With
            .Range(.Cells(1, 1), .Cells(LR, LC)).AutoFilter Field:=3, Criteria1:=cel.Value
            Set Rng = .AutoFilter.Range
            Rng.Resize(Rng.Rows.Count - 1).Copy
            NewBook.Sheets("Sheet1").Range("A1").PasteSpecial Paste:=8
            NewBook.Sheets("Sheet1").Range("A1").PasteSpecial
            NewBook.Close True
        Next cel
        .AutoFilterMode = False
    End With
    Application.DisplayAlerts = False
    Sheets("Lists").Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

**krjoshi** · 07-10-2012, 10:36 PM

Hi Jaslake,

Thanks alot, its working great. Can we add one more condition? If the workbook name existing I want to open that workbook and paste the filtered values. (e.g. if Valve-Manual.xlsx is existing, open that workbook, activate sheet1, clear all cells and paste the filtered data then close the workbook).

I think this is an extremely tough one, not even sure this is possible!

Thanks in advance,
Joshi

**jaslake** · 07-11-2012, 08:43 AM

Hi Joshi
This code accomplishes this

If the workbook name existing I want to open that workbook and paste the filtered values. (e.g. if Valve-Manual.xlsx is existing, open that workbook, activate sheet1, clear all cells and paste the filtered data then close the workbook).

Option Explicit

Sub Macro1()
    Dim NewBook As Workbook
    Dim MyPath As String
    Dim Rng As Range
    Dim cel As Range
    Dim LR As Long
    Dim LC As Long

    Application.ScreenUpdating = False
    MyPath = "C:\joshi"

    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Lists").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Worksheets.Add After:=ActiveSheet
    ActiveSheet.Name = "Lists"
    With Sheets("All_Jobs")
        If Not .AutoFilterMode Then
            .Range("A1").AutoFilter
        End If
        LR = .Range("A" & .Rows.Count).End(xlUp).Row
        LC = .Cells.Find(What:="*", After:=[A1], _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious).Column
        .Columns("C:C").AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=Sheets("Lists").Range("A1"), Unique:=True
        ActiveWorkbook.Names.Add Name:="FLists", RefersTo:= _
                "=OFFSET(Lists!$A$2,0,0,(COUNTA(Lists!$A:$A)-1),1)"
        For Each cel In Range("FLists")
            If Not FileFolderExists(MyPath & "\" & cel.Value & ".xlsx") Then
                Set NewBook = Workbooks.Add
                With NewBook
                    .SaveAs Filename:=MyPath & "\" & cel.Value & ".xlsx"
                End With
            Else
                Workbooks.Open MyPath & "\" & cel.Value & ".xlsx"
                Set NewBook = ActiveWorkbook
                With NewBook.Sheets("Sheet1")
                    .Cells.Clear
                End With
            End If
            .Range(.Cells(1, 1), .Cells(LR, LC)).AutoFilter Field:=3, Criteria1:=cel.Value
            Set Rng = .AutoFilter.Range
            Rng.Resize(Rng.Rows.Count - 1).Copy
            NewBook.Sheets("Sheet1").Range("A1").PasteSpecial Paste:=8
            NewBook.Sheets("Sheet1").Range("A1").PasteSpecial
            NewBook.Close True
        Next cel
        .AutoFilterMode = False
    End With
    Application.DisplayAlerts = False
    Sheets("Lists").Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub


Public Function FileFolderExists(strFullPath As String) As Boolean
'Author       : Ken Puls (www.excelguru.ca)
'Macro Purpose: Check if a file or folder exists

    On Error GoTo EarlyExit
    If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True

EarlyExit:
    On Error GoTo 0

End Function

Let me know of issues.

**krjoshi** · 07-11-2012, 10:25 AM

Hi Jaslake,
Thanks for your quick reply. One more small issue, I have added some records at bottom and ran the macro again, new workbooks are creating based on new cell values with header but without data. Please help me to resolve this issue.

Thanks,
Joshi

**jaslake** · 07-11-2012, 10:57 AM

Hi Joshi
Try this...if this doesn't fix it I'll need to see your modified file.

Option Explicit

Sub Macro1()
    Dim NewBook As Workbook
    Dim MyPath As String
    Dim Rng As Range
    Dim cel As Range
    Dim LR As Long
    Dim LC As Long

    Application.ScreenUpdating = False
    MyPath = "C:\joshi"

    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Lists").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Worksheets.Add After:=ActiveSheet
    ActiveSheet.Name = "Lists"
    With Sheets("All_Jobs")
        If Not .AutoFilterMode Then
            .Range("A1").AutoFilter
        End If
        LR = .Cells.Find("*", .Cells(Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row
        '        LR = .Range("A" & .Rows.Count).End(xlUp).Row
        LC = .Cells.Find(What:="*", After:=[A1], _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious).Column
        .Columns("C:C").AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=Sheets("Lists").Range("A1"), Unique:=True
        ActiveWorkbook.Names.Add Name:="FLists", RefersTo:= _
                "=OFFSET(Lists!$A$2,0,0,(COUNTA(Lists!$A:$A)-1),1)"
        For Each cel In Range("FLists")
            If Not FileFolderExists(MyPath & "\" & cel.Value & ".xlsx") Then
                Set NewBook = Workbooks.Add
                With NewBook
                    .SaveAs Filename:=MyPath & "\" & cel.Value & ".xlsx"
                End With
            Else
                Workbooks.Open MyPath & "\" & cel.Value & ".xlsx"
                Set NewBook = ActiveWorkbook
                With NewBook.Sheets("Sheet1")
                    .Cells.Clear
                End With
            End If
            .Range(.Cells(1, 1), .Cells(LR, LC)).AutoFilter Field:=3, Criteria1:=cel.Value
            Set Rng = .AutoFilter.Range
            Rng.Resize(Rng.Rows.Count - 1).Copy
            NewBook.Sheets("Sheet1").Range("A1").PasteSpecial Paste:=8
            NewBook.Sheets("Sheet1").Range("A1").PasteSpecial
            NewBook.Close True
        Next cel
        .AutoFilterMode = False
    End With
    Application.DisplayAlerts = False
    Sheets("Lists").Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub


Public Function FileFolderExists(strFullPath As String) As Boolean
'Author       : Ken Puls (www.excelguru.ca)
'Macro Purpose: Check if a file or folder exists

    On Error GoTo EarlyExit
    If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True

EarlyExit:
    On Error GoTo 0

End Function

**krjoshi** · 07-11-2012, 12:48 PM

Hi Jaslake,
Thanks for your quick reply. Still the bottom record is not copying. Please find attached the file as advised.

Thank you so much for your time.
Joshi

**jaslake** · 07-11-2012, 01:43 PM

Hi joshi
Change this line of code from

Rng.Resize(Rng.Rows.Count - 1).Copy

to

Rng.Resize(Rng.Rows.Count).Copy

Silly error..didn't look close enough. Let me know of issues.

**krjoshi** · 07-11-2012, 01:58 PM

Hi Jaslake,
Thanks for your quick reply. Still the problem exists, last record is not copying. I noticed that if I repeat the last record then it’s copying

Thank you so much for your time.
Joshi

**jaslake** · 07-11-2012, 02:56 PM

Hi joshi
Were you able to change the line of code I referenced? The code appears to work for me on your new file with that change. I'm going to post all the code once again...let me know of issues.

Option Explicit

Sub Macro1()
    Dim NewBook As Workbook
    Dim MyPath As String
    Dim Rng As Range
    Dim cel As Range
    Dim LR As Long
    Dim LC As Long

    Application.ScreenUpdating = False
    MyPath = "C:\joshi"

    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Lists").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Worksheets.Add After:=ActiveSheet
    ActiveSheet.Name = "Lists"
    With Sheets("All_Jobs")
        If Not .AutoFilterMode Then
            .Range("A1").AutoFilter
        End If
        LR = .Range("A" & .Rows.Count).End(xlUp).Row
        LC = .Cells.Find(What:="*", After:=[A1], _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious).Column
        .Columns("C:C").AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=Sheets("Lists").Range("A1"), Unique:=True
        ActiveWorkbook.Names.Add Name:="FLists", RefersTo:= _
                "=OFFSET(Lists!$A$2,0,0,(COUNTA(Lists!$A:$A)-1),1)"
        For Each cel In Range("FLists")
            If Not FileFolderExists(MyPath & "\" & cel.Value & ".xlsx") Then
                Set NewBook = Workbooks.Add
                With NewBook
                    .SaveAs Filename:=MyPath & "\" & cel.Value & ".xlsx"
                End With
            Else
                Workbooks.Open MyPath & "\" & cel.Value & ".xlsx"
                Set NewBook = ActiveWorkbook
                With NewBook.Sheets("Sheet1")
                    .Cells.Clear
                End With
            End If
            .Range(.Cells(1, 1), .Cells(LR, LC)).AutoFilter Field:=3, Criteria1:=cel.Value
            Set Rng = .AutoFilter.Range
            Rng.Resize(Rng.Rows.Count).Copy
            NewBook.Sheets("Sheet1").Range("A1").PasteSpecial Paste:=8
            NewBook.Sheets("Sheet1").Range("A1").PasteSpecial
            NewBook.Close True
        Next cel
        .AutoFilterMode = False
    End With
    Application.DisplayAlerts = False
    Sheets("Lists").Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub


Public Function FileFolderExists(strFullPath As String) As Boolean
'Macro Purpose: Check if a file or folder exists

    On Error GoTo EarlyExit
    If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True

EarlyExit:
    On Error GoTo 0

End Function

**krjoshi** · 08-06-2012, 07:12 AM

Hi Jaslake,
It’s working great. Sorry for the delayed reply.

Thanks,
Joshi

VBA Help needed - Filter data and save as separate workbook

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

VBA Help needed - Filter data and save as separate workbook

Re: VBA Help needed - Filter data and save as separate workbook

Re: VBA Help needed - Filter data and save as separate workbook

Re: VBA Help needed - Filter data and save as separate workbook

Re: VBA Help needed - Filter data and save as separate workbook

Re: VBA Help needed - Filter data and save as separate workbook

Re: VBA Help needed - Filter data and save as separate workbook

Re: VBA Help needed - Filter data and save as separate workbook

Re: VBA Help needed - Filter data and save as separate workbook

Re: VBA Help needed - Filter data and save as separate workbook

Re: VBA Help needed - Filter data and save as separate workbook

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions