Solved

filter a excel docuement using VBA and export results

Posted on 2014-09-26
48
842 Views
Last Modified: 2014-11-11
I want to filter a excel doc, and save the results in a new .xlsx (same directory) with the current filename_filtervalue.xlsx

I.E. current filename is "new", and I am filtering in column C with the text "grass", I want the macro to save the file as: "new_grass.xlsx" in the same directory as the active workbook.

1) the parameters that I will be filtering will change every time, so I want the VBA to look at "first choice" to filter, then save, look at the "second choice" to filter than save, look at the "third choice" to filter then save etc.

2)  I think the vba can  reference what is in cell C1 after the filter is applied to know what filter value to add to the filename.

3) FYI I am using the following code to create the initial workbook that will be filtered.  This workbook was originally a .csv that will be saved as current filename.xlsx after I run the first part of the macro.

'Function:

Public Function s_as(xlsx As String) As String
s_as = ActiveWorkbook.FullName
s_as = Left(s_as, InStrRev(s_as, ".")) & xlsx
End Function


'USAGE:

ActiveWorkbook.SaveAs FileName:=s_as("xlsx"), FileFormat:=xlOpenXMLWorkbook


4) I will not need code examples of how to cut and paste the results in the new .xlsx,
just help with the filtering, and the save as of the new file.

5) IF you could give me the sub proceedure code/function code as well as the usage code (how it will be called out from another module) that would be greatly appreciated.

thanks
0
Comment
Question by:tike55
  • 25
  • 21
48 Comments
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40347031
What's the filter criteria?
0
 

Author Comment

by:tike55
ID: 40350194
can I program the vba to select the "next" available filter criterea?

it will be a list of categories like "taxable" "produce" etc.  Up to 35 categories, amount could change every time.
0
 

Author Comment

by:tike55
ID: 40353376
Any expert out there with a solution to this question?
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40353389
from what I understand you want to create a spate workbook based on the unique values of a single column.

is that correct?
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40353390
if yes, then let me know. I have the code ready for you.
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40353400
see the attached workbook example.

in this example  it is assumed that the column which you want to filter and have each file separately created for each individual unique company.  run the macro called "splitCompany"  then follow along
F--Split-Data-Based-on-Column-Value.xls
0
 

Author Comment

by:tike55
ID: 40353592
yes
0
 
LVL 45

Expert Comment

by:Martin Liss
ID: 40411066
I've requested that this question be deleted for the following reason:

Not enough information to confirm an answer.
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40411067
MartinLiss

i object to this closure "Not enough information"

I have spent time, creating the file and the solution which is exactly what the asker tike55 have requested. if he does not provide feedback, it shouldn't be at the cost of my time.

I recommend that the question will be closed by acceptance of the post ID: 40353400
0
 

Author Comment

by:tike55
ID: 40411315
Please Do not close!

I have been busy, working on this project again
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40411319
tike55

see my post ProfessorJimJam2014-09-30 at 23:31:07ID: 40353400  

that is the solution. please let me know.
0
 

Author Comment

by:tike55
ID: 40411416
Hi Professor!

that is awesome.  This is sooo much help!  

I ran the macro, could you help me with a few adjustments & one question:

1) could you make the macro compatible with 64 bit systems?  I am getting an error
2) could you take away prompt at the end "do you want to save as workbooks" and just have have them save out as workbooks in the same directory, as well as having the master workbook saved?
3) could you take away the completed in 2 millisecond prompt
4) could you just have it always filter on column L  

1) Will this macro work with any workbook?  or does it have to have a certain column layout?
0
 

Author Comment

by:tike55
ID: 40411566
HI Professor,

the main fix would be to make it compatible with 64 bit systems

if you could help me with the other adjustments that would be great.  Once I hear back from you I will close the question. Sorry it took so long to get back.
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40411580
Give me 2 hours I am away from my computer, as soon as I get home I will send u code
0
 

Author Comment

by:tike55
ID: 40411616
Awsome!  thanks man -  If I could get all 5 issues above fixed the macro will be perfect!
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40411919
here is the code

Sub SplitWorkbook()
    Dim colLetter As String, SavePath As String
    Dim lastValue As String
    Dim wb As Workbook
    Dim lng As Long
    Dim currentRow As Long
    Dim Fname As String, FFname As String
    Fname = ThisWorkbook.Name
    FFname = Left(Fname, InStr(Fname, ".") - 1)
    Application.ScreenUpdating = False
    colLetter = "L"
    SavePath = ActiveWorkbook.path
    'Sort the workbook.
    With ActiveWorkbook.Worksheets(1)
        .Sort.SortFields.Add Key:=.Range(colLetter & ":" & colLetter), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange .Parent.UsedRange.Cells
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        For lng = 2 To .Range(colLetter & .Rows.Count).End(xlUp).Row
            If .Cells(lng, colLetter).Value = "" Then Exit For
            lastValue = .Cells(lng, colLetter).Value
            .Cells.AutoFilter field:=.Cells(lng, colLetter).Column, Criteria1:=lastValue
            lng = .Cells(.Rows.Count, colLetter).End(xlUp).Row
            Set wb = Application.Workbooks.Add(xlWorksheet)
            wb.Sheets(1).Name = "Split"
            .Rows(1 & ":" & lng).Copy wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp)
            wb.SaveAs SavePath & "\" & FFname & " " & Replace(lastValue, ".", " "), 52
            wb.Close
        Next
        .AutoFilterMode = False
    End With
    Application.ScreenUpdating = True
End Sub

Open in new window

0
 

Author Comment

by:tike55
ID: 40411980
thanks,

I will try it and let you know asap how it works.  Should I just drop the code in a new module?
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40411991
yes

put it in a new module on the workbook the one which you want to split its data based on column L

it will not give you any prompt.  it will save all workbooks in the same folder as the original workbook.
0
 

Author Comment

by:tike55
ID: 40412086
this is close!  
1) I am storing the macro in a personal.xlsm workbook.  It is saving a extra copy of this workbook in the directory as xlsx as well as a xlsx of the active workbook.  could it just be the active workbook.
 
2) the code is not saving out the filtered results in new xlsx files

3) could the worksheet tabs that it creates before the export be preserved and saved in the initial xlsx file.  So, the final result would be:

original csv (preserved and closed)
original xlsx (saved with filtered tabs)
exported xlsx workbooks (based upon filter results)


thanks I super appreciate your help!
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40412280
try this one

Sub SplitWorkbooks()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String
On Error Resume Next
Set r = Range("A:A")
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
    Master = .Name
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LastRow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True


    Application.ScreenUpdating = False
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> Master Then
            sh.Copy
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.path & "\" & sh.Name & ".xlsx"
            ActiveWorkbook.Close
        End If
     Next sh
     Application.ScreenUpdating = True
ThisWorkbook.Save
ThisWorkbook.Close
End Sub

Open in new window

0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40413479
i forgot to change the column  now it is changed to column L and took care of the new grass prefix

Sub SplitWorkbooks()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String
On Error Resume Next
Set r = Range("L:L")
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
    Master = .Name
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LastRow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
Prefix = "new_grass"
    Application.ScreenUpdating = False
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> Master Then
            sh.Copy
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.path & "\" & Prefix & sh.Name & ".xlsx"
            ActiveWorkbook.Close
        End If
     Next sh
     Application.ScreenUpdating = True
ThisWorkbook.Save
ThisWorkbook.Close
End Sub

Open in new window

0
 

Author Comment

by:tike55
ID: 40413494
SOOO CLOSE!
All that needs to happen is:

 1) original csv (should be: preserved and closed)- original file not being preserved and closing, tabs are also being added to this worksheet instead of original xlsx

 2) original xlsx (should be: saved with filtered tabs, left open and saved) - not being created or saved
 
 3) exported xlsx workbooks (based upon filter results)  - it created a 1 blank excel worksheet called sheet 1.  (should be:  1 xlsx file per each filter result).  All of these files should be saved and closed with the following naming scheme:  I.E. current filename is "new", and I am filtering in column C with the text "grass", I want the macro to save the file as: "new_grass.xlsx" in the same directory as the active workbook.

 thanks!
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40413509
i am lost, i am not sure what is required further.   i have changed the macro many times.
0
Do You Know the 4 Main Threat Actor Types?

Do you know the main threat actor types? Most attackers fall into one of four categories, each with their own favored tactics, techniques, and procedures.

 

Author Comment

by:tike55
ID: 40413662
sorry man! I really appreciate your help, can we try 1 more revision?  Please bare with me, we are soo close!
Hopefully my comments below will clarify.

objective:
original csv (preserved and closed)
original xlsx (created, saved in same directory, and left open with filtered tabs)
exported xlsx workbooks (created, saved in same directory and closed)

remaining issues:
1) original csv - right now the original file (active workbook) is  not being preserved and closing.   Tabs are also being added to this worksheet instead of  a new original xlsx file.    Could this csv file be preserved and closed?

  2) original xlsx - right now this  is not being created or saved. Could this xlsx be created, saved  in the same directory as original.csv, and left open with filtered tabs.
 
  3) exported xlsx workbooks  - right now the macro just creates 1 blank excel worksheet called sheet 1.  Could the macro create 1 xlsx file per each filter result, saved and closed in the same directory as original.csv.
0
 

Author Comment

by:tike55
ID: 40413668
I cannot tell you how much I appreciate your help!!!!
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40413697
Ok, then i will try for the last time.

please answer the following question

1) original csv   should this file be affected at all?  is this the source file based on which from its data the new sheets are created and saved in separate files?  once the workbooks created you want the csv to be saved with having multiple tabs(sheets) in it? and then saved and closed?   if yes: then sorry the CSV format file cannot support having multiple sheets in its workbook.  then is not possible at all.
2) original xlsx   what is this file? is this cvs file  in form of xlsx?  do you want the tabs created and saved in xlsx format?

 3) exported xlsx   This part should not have any problem.  please tell me what is the column number/Name based on which the data needs to split. you told me it is column L and the latest code i posted, considers column L having data. i assume when you run the code your column L did not have data in it. please confirm the column.
0
 

Author Comment

by:tike55
ID: 40413771
1) original csv should not be affected.  It is just the source file. no tabs. Just copy to make original.xlsx.  After the macro runs, close this file.

2)original.xlsx is a file created from original.csv.   I want tabs created in this file. Please filter on column  D
 (do not use column L- was my bad) After the macro runs, save and leave this file open.

3) create 1 export.xlsx for each of the filtered tabs above.  After the macro runs, these files should be saved and closed.
0
 

Author Comment

by:tike55
ID: 40413824
hopefully that helps!
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40413905
the only question i have is where are you going to place the macro module?  because in CVS cannot hold any module.  will you be running this from Personal.xlsb?
0
 

Author Comment

by:tike55
ID: 40413932
it will be in my personal.xls file.  So all of the actions should be preformed on the active worksheet (csv) .
0
 

Author Comment

by:tike55
ID: 40413933
personal.xlsm file
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40413942
ok.  give me sometime, as i am not close to my PC.  i will get you a possible solution as soon as i can.
0
 

Author Comment

by:tike55
ID: 40413965
Also worth noting,

1) all files should be created in same directory as original.csv

2) the file names of the csv's will always be different,  I am using "original" for the purposes of explaning the macro to you.

3) All of the exported files should be saved and closed with the following naming scheme:  I.E. original.xlsx filename is "new.xlsx".  First tab is named "grass" (based upon filter results), I want the macro to save the exported file as: "new_grass.xlsx" in the same directory as the active workbook.  Second tab is named "water" (based upon filter results), I want the macro to save the exported file as : "new_water.xlsx" in the same directory as the active workbook (etc).
0
 

Author Comment

by:tike55
ID: 40413968
Last note:

only workbook that should be open after the macro runs should be original.xlsx. Keep it open on the first tab, with no cells selected.  

thank you thank you thank you!
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40422921
Here you go

put this code into a module of your Personal.xlsm and then when opened your csv file RUN the macro called "SPLITMACRO" and then it will do exactly as you requested.  

let me know.

Sub SPLITMACRO()

 '  11/4/2014  by ProfessorJimJam  Solution to question number Q28526576
    Dim colLetter As String, SavePath As String
    Dim lastValue As String
    Dim wb As Workbook
    Dim lng As Long
    Dim currentRow As Long
        Dim FN As String, FF As String
    colLetter = "D"
    SavePath = "" 'Indicate the path to save
    If SavePath = "" Then SavePath = ActiveWorkbook.Path
    'Sort the workbook.
    Application.ScreenUpdating = False
    With ActiveWorkbook.Worksheets(1)
        .Sort.SortFields.Add Key:=.Range(colLetter & ":" & colLetter), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange .Parent.UsedRange.Cells
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        For lng = 2 To .Range(colLetter & .Rows.Count).End(xlUp).Row
            If .Cells(lng, colLetter).Value = "" Then Exit For
            lastValue = .Cells(lng, colLetter).Value
            .Cells.AutoFilter field:=.Cells(lng, colLetter).Column, Criteria1:=lastValue
            lng = .Cells(.Rows.Count, colLetter).End(xlUp).Row
            Set wb = Application.Workbooks.Add(xlWorksheet)
            wb.Sheets(1).Name = lastValue
            .Rows(1 & ":" & lng).Copy wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp)
            wb.SaveAs SavePath & "\" & "new_grass" & " " & Replace(lastValue, ".", " "), 51
            wb.Close
        Next
        .AutoFilterMode = False
    End With
Call SplitSheets
Call Filteron
FN = ActiveWorkbook.FullName
FF = Left(FN, Len(FN) - 3)
    ActiveWorkbook.SaveAs Filename:=FF & "xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    Application.ScreenUpdating = True
End Sub
Private Sub SplitSheets()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String
On Error Resume Next
Set r = Range("D:D")
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveWorkbook.Worksheets(1)
    Master = .Name
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LastRow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
End Sub

Private Sub Filteron()

    Dim ws As Worksheet
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        ws.Activate
        Range("A1").Activate
        Selection.AutoFilter
    Next ws
    Application.ScreenUpdating = True

End Sub

Open in new window

0
 

Author Comment

by:tike55
ID: 40426824
thank you ! I will try today and let you know how it works
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40426847
it will surely work. as i tested it before posting it here. ;-)
0
 

Author Comment

by:tike55
ID: 40426852
AWSOME!!!!! You are sooo awesome!  

1 adjustment:

the macro is not creating new separate xlsx worksheets based upon the filter results on each tab.  See 40413965

So could you keep the macro as is, and just ad this functionality at the end?
0
 

Author Comment

by:tike55
ID: 40426857
So to be clear, the macro is working as requested except for the last part.

If each tab can be exported out to its on individual worksheet in the same directory that would be fantastic.

use the following naming scheme ( I.E. original.xlsx filename is "new.xlsx".  First tab is named "grass" (based upon filter results), I want the macro to save the exported file as: "new_grass.xlsx" in the same directory as the active workbook.  Second tab is named "water" (based upon filter results), I want the macro to save the exported file as : "new_water.xlsx" in the same directory as the active workbook (etc).
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40426893
look, you must have done something, there the macro works.    check your column is it D? Column D?

the macro does the following

A) creates indivitual workbooks in the same directory as where the csv file is located, for each unique filtered values as per column D the files are saved as xlsx with prefix of Grass_UnqiueValuename and then it also creates new workbook with normal file extention of xlsx that has multiple sheets each sheet for each unique value based on column D. then it also saves the new created file that has many worksheets in the same directory where the csv file is. the file name is also the same as csv , except that it is in a xlsx ext.


i do not understand what part is not working.  do you want the new file to be named "original"? instead of having the same name as csv name?
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40426919
see the modified code below,  creates the original.xlsx as well.  all of the created files are in the same directory folder where the csv is located.

the seperate files created will have a prefix of "new" and the the tab name saved in the same directory as the csv file

Sub SPLITMACRO()

 '  11/4/2014  by ProfessorJimJam  Solution to question number Q28526576
    Dim colLetter As String, SavePath As String
    Dim lastValue As String
    Dim wb As Workbook
    Dim lng As Long
    Dim currentRow As Long
        Dim FN As String, FF As String
    colLetter = "D"
    SavePath = "" 'Indicate the path to save
    If SavePath = "" Then SavePath = ActiveWorkbook.path
    'Sort the workbook.
    Application.ScreenUpdating = False
    With ActiveWorkbook.Worksheets(1)
        .Sort.SortFields.Add Key:=.Range(colLetter & ":" & colLetter), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange .Parent.UsedRange.Cells
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        For lng = 2 To .Range(colLetter & .Rows.Count).End(xlUp).Row
            If .Cells(lng, colLetter).Value = "" Then Exit For
            lastValue = .Cells(lng, colLetter).Value
            .Cells.AutoFilter field:=.Cells(lng, colLetter).Column, Criteria1:=lastValue
            lng = .Cells(.Rows.Count, colLetter).End(xlUp).Row
            Set wb = Application.Workbooks.Add(xlWorksheet)
            wb.Sheets(1).Name = lastValue
            .Rows(1 & ":" & lng).Copy wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp)
            wb.SaveAs SavePath & "\" & "New" & " " & Replace(lastValue, ".", " "), 51
            wb.Close
        Next
        .AutoFilterMode = False
    End With
Call SplitSheets
Call Filteron

   ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.path & "\" & "original", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    Application.ScreenUpdating = True

End Sub
Private Sub SplitSheets()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String
On Error Resume Next
Set r = Range("D:D")
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveWorkbook.Worksheets(1)
    Master = .Name
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LastRow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
End Sub

Private Sub Filteron()

    Dim ws As Worksheet
    Application.ScreenUpdating = False
   On Error Resume Next
    For Each ws In ActiveWorkbook.Worksheets
        ws.Activate
        Range("A1").Activate
        Selection.AutoFilter
    Next ws
    Application.ScreenUpdating = True
On Error GoTo 0
End Sub

Open in new window

0
 
LVL 25

Expert Comment

by:ProfessorJimJam
ID: 40426930
please check and let me know.   this issue really been dragged for long. i want to close this chapter asap.
0
 

Author Comment

by:tike55
ID: 40427291
HI Professor,

I just realized the code in ID: 40422921 works with one exception:

In order to articulate my idea correctly I have attached a csv example to be more clear, and save you any more headaches and time!  

attached is exampl1 9.9.14.csv

after the macro is run there should be the following spreadsheets:

1)  exampl1 9.9.14.csv (closed and saved)

2)  exampl1 9.9.14.xlsx (saved in same directory and still open on first tab) (this workbook should have 3 worksheets based upon filter results named: hiking supply, socks, bars)

3) exampl1 9.9.14_hiking supply.xlsx (closed and saved in the same directory)
    exampl1 9.9.14_socks.xlsx (closed and saved in the same directory)
    exampl1 9.9.14_bars.xlsx (closed and saved in the same directory)
example1-9.9.14.xlsx
0
 

Author Comment

by:tike55
ID: 40427298
Hopefully my last post will be helpful and expedite the development. Believe me I want to put this to rest ASAP..

I super apprecieate your help!!!
0
 

Author Comment

by:tike55
ID: 40427345
keep in mind the csv will be named different everytime, so the corresponding spreadsheets should be variable as well
0
 
LVL 25

Accepted Solution

by:
ProfessorJimJam earned 500 total points
ID: 40429727
Here is the modified code

please let me know.

Sub SPLITMACRO()

 '  11/7/2014  by ProfessorJimJam  Solution to question number Q28526576
    Dim colLetter As String, SavePath As String
    Dim lastValue As String
    Dim wb As Workbook
    Dim lng As Long
    Dim currentRow As Long
        Dim FN As String, FF As String, FFF As String, FQ As String
        FQ = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 3)
        FFF = Replace(FQ, ".", " ")
    colLetter = "D"
    SavePath = "" 'Indicate the path to save
    If SavePath = "" Then SavePath = ActiveWorkbook.path
    'Sort the workbook.
    Application.ScreenUpdating = False
    With ActiveWorkbook.Worksheets(1)
        .Sort.SortFields.Add Key:=.Range(colLetter & ":" & colLetter), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange .Parent.UsedRange.Cells
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        For lng = 2 To .Range(colLetter & .Rows.Count).End(xlUp).Row
            If .Cells(lng, colLetter).Value = "" Then Exit For
            lastValue = .Cells(lng, colLetter).Value
            .Cells.AutoFilter field:=.Cells(lng, colLetter).Column, Criteria1:=lastValue
            lng = .Cells(.Rows.Count, colLetter).End(xlUp).Row
            Set wb = Application.Workbooks.Add(xlWorksheet)
            wb.Sheets(1).Name = lastValue
            .Rows(1 & ":" & lng).Copy wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp)
            wb.SaveAs SavePath & "\" & FFF & "_" & Replace(lastValue, ".", " "), 51
            wb.Save
            wb.Close
        Next
        .AutoFilterMode = False
    End With
Call SplitSheets
Call Filteron
FN = ActiveWorkbook.FullName
FF = Left(FN, Len(FN) - 3)
    ActiveWorkbook.SaveAs Filename:=FF & "xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    Application.ScreenUpdating = True
End Sub
Private Sub SplitSheets()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String
On Error Resume Next
Set r = Range("D:D")
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveWorkbook.Worksheets(1)
    Master = .Name
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LastRow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
End Sub

Private Sub Filteron()

    Dim ws As Worksheet
    Application.ScreenUpdating = False
   On Error Resume Next
    For Each ws In ActiveWorkbook.Worksheets
        ws.Activate
        Range("A1").Activate
        Selection.AutoFilter
    Next ws
    
ActiveWorkbook.Worksheets(1).Select
    Application.ScreenUpdating = True
On Error GoTo 0
End Sub

Open in new window

0
 

Author Closing Comment

by:tike55
ID: 40435489
Awsome Expert worthy of MVP
0

Featured Post

How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

Join & Write a Comment

Background What I'm presenting in this article is the result of 2 conditions in my work area: We have a SQL Server production environment but no development or test environment; andWe have an MS Access front end using tables in SQL Server but we a…
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.

746 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now