Split data into separate file and save according to filename

[pesteness]

Hi ExcelFox

i have provided a sample files.

i want to seperate the file per part number and save as filename inside the File.xlsx but the file should be on a csv format (SensorExhaustOxygenPFOS730.csv), i hope somebody can help me on this,

the file on "SensorExhaustOxygenPFOS730.xlsx" should be the result, but on a csv format



Thanks,
Pesteness

cross post section:
http://www.ozgrid.com/forum/showthread.php?t=168821&p=623504#post623504

[Admin]

Hi Pesteness,

Welcome to ExcelFox!!

Download the workbook from here:

http://www.excelfox.com/forum/f12/split-data-into-multiple-files-33/#post81

[pesteness]

Hi Pesteness,

Welcome to ExcelFox!!

Download the workbook from here:

http://www.excelfox.com/forum/f12/split-data-into-multiple-files-33/#post81



Hi Admin,

Thanks for the reply, however the title should not be replaced with title1,2,3 etc. as well as the picture and part number , i need the data on it, look at the "SensorExhaustOxygenPFOS730.xlsx" the output should supposed to be like that, i have provided a filename that you can use on the filename column, the program will split the data for part number.

example part number:PFOS730
the program will filter all the "PFOS730" in workbook, as you can see in the file.xlsx there so many "PFOS730" i want to filter all and split to a new workbook

l
Again, Thank you.

[Admin]

Hi

Sorry for the confusion. That's only dummy data. You have to replace those data with your actual data.

[pesteness]

Hi

Sorry for the confusion. That's only dummy data. You have to replace those data with your actual data.
its okay,

yes, i already did that but still the macro just grab a single data, for example this part number "PFOS786" has some duplicate in the my DATA but it has different title, what i wanted to happen is gather all the data within this part number "PFOS786" in one workbook, like below sample, and use the file name in the filename section so for this part number the file name should be "SensorExhaustOxygenPFOS786"


Part # title etc etc etc....
PFOS786 Alfa Romeo 75 Twin Spark 4 Cyl 2.0L Exhaust Oxygen Sensor
PFOS786 Alfa Romeo 75 V6 Cyl 3.0L Exhaust Oxygen Sensor
PFOS786 Alfa Romeo 164 V6 Cyl 3.0L Exhaust Oxygen Sensor
PFOS786 Audi 80 Quattro 4 Cyl 1.8L Exhaust Oxygen Sensor
PFOS786 Audi 90 Sport Quattro 5 Cyl 2.3L Exhaust Oxygen Sensor
PFOS786 Audi 200 Turbo 5 Cyl 2.2L Exhaust Oxygen Sensor
PFOS786 Audi Quattro V8 Cyl 3.6L Exhaust Oxygen Sensor
PFOS786 Audi S4 Turbo 5 Cyl 2.2L Exhaust Oxygen Sensor
PFOS786 Jaguar Sovereign 6 Cyl 3.6L Exhaust Oxygen Sensor
PFOS786 Jaguar XJS Sport 6 Cyl 4.0L Exhaust Oxygen Sensor
PFOS786 Jaguar XJS V12 Cyl 6.0L Exhaust Oxygen Sensor
PFOS786 Saab 9000 4 Cyl 2.0L Exhaust Oxygen Sensor
PFOS786 Volvo 240 4 Cyl Exhaust Oxygen Sensor
PFOS786 Volvo 740 Turbo 4 Cyl Exhaust Oxygen Sensor
PFOS786 Volvo 740 4 Cyl Exhaust Oxygen Sensor
PFOS786 Volvo 760 Turbo 4 Cyl Exhaust Oxygen Sensor

Thanks and God Bless.

[Admin]

Hi

It's working fine here. I got 16 rows of data for SensorExhaustOxygenPFOS786.CSV.

To fix the file name

replace


wbkNewFile.SaveAs strOutPutFolder & varUniques(lngLoop) & strFileFormat, lngFileFormatNum

with


wbkNewFile.SaveAs strOutPutFolder & rngToCopy.Cells(2, 1) & strFileFormat, lngFileFormatNum

Post back if any help needed.

HTH

[pesteness]

yea! its now working thanks for your help, the only problem now is the filename, i already changed the code from that, but nothings changed and the macro split only single data.


THANKS :)

[Admin]

Sorry, it should be


wbkNewFile.SaveAs strOutPutFolder & wbkNewFile.Worksheets(1).Range("a2") & strFileFormat, lngFileFormatNum

[pesteness]

Sorry, it should be


wbkNewFile.SaveAs strOutPutFolder & wbkNewFile.Worksheets(1).Range("a2") & strFileFormat, lngFileFormatNum

wow, awesome i never knew that someone can answer this, you're a beast! :cheers:
I'm starting to like this website, thank you so much for your help. :cool:
i will post something again, hope you can help me again, just a very simple code :o

[pesteness]

Hi Admin,

about the "split data program" i noticed that the "column A" (file name) is also in the output of the program, i just want to removed the column A (file name) on the output and the part number should start in that column, that file name is just for the files name. thanks god bless:)

[pesteness]

Hi Admin,

about the "split data program" i noticed that the "column A" (file name) is also in the output of the program, i just want to removed the column A (file name) on the output and the part number should start in that column, that file name is just for the files name. thanks god bless:) .

[Admin]

Hi,

Try this code. Also type 1 in C6 on ControlSheet


'ExcelFox.com
Const Ttle As String = "ExcelFox.com"
Sub SplitDataIntoMultipleFiles_V1()

Dim wbkActive As Workbook
Dim strFolderPath As String
Dim varCols As Variant
Dim lngSplitCol As Long
Dim strOutPutFolder As String
Dim strFileFormat As String
Dim wksData As Worksheet
Dim blnSplitAllCol As Boolean
Dim varUniques As Variant
Dim strDataRange As String
Dim rngData As Range
Dim lngLoop As Long
Dim lngLoopCol As Long
Dim rngToCopy As Range
Dim wbkNewFile As Workbook
Dim i As Long
Dim lngFileFormatNum As Long
Dim NewFileName As String


On Error Resume Next
Set wbkActive = ThisWorkbook
Set wksData = wbkActive.Worksheets(CStr(Range("wksName")))
If Err.Number <> 0 Then
MsgBox "Sheet name '" & Range("wksName").Text & "' not found", vbCritical, Ttle
Err.Clear
Exit Sub
End If
strFolderPath = wbkActive.Path & Application.PathSeparator
If Len(Range("DataCols")) Then
varCols = Split(Range("DataCols").Value, ",")
Else
blnSplitAllCol = True
End If
If Len(Range("SplitCol").Value) = 0 Then
MsgBox "Column to Split must not be empty", vbCritical, Ttle
Err.Clear
Exit Sub
End If
lngSplitCol = CLng(Range("SplitCol").Value)

If Right$(Range("OutputFolderPath"), 1) <> "\" Then
strOutPutFolder = Range("OutputFolderPath") & "\"
End If

If Not CBool(Len(Dir(strOutPutFolder, 16))) Then
strOutPutFolder = strFolderPath
End If

strFileFormat = IIf(Len(Range("OutputFileFormat").Text), Range("OutputFileFormat").Text, ".CSV")

If Len(Range("DataRange")) = 0 Then
strDataRange = wksData.UsedRange.Address
Else
strDataRange = Range("DataRange")
End If

Set rngData = Application.Intersect(wksData.UsedRange, wksData.Range(strDataRange))

varUniques = UNIQUEIF(rngData.Columns(lngSplitCol), 2)

With Application
.ScreenUpdating = 0
.DisplayAlerts = 0
End With

If IsArray(varUniques) Then
Select Case CLng(Application.Version)
Case Is < 12
If UCase$(strFileFormat) = ".XLS" Then
lngFileFormatNum = -4143
ElseIf UCase$(strFileFormat) = ".CSV" Then
lngFileFormatNum = 6
End If
Case Else
If UCase$(strFileFormat) = ".XLS" Then
lngFileFormatNum = 56
ElseIf UCase$(strFileFormat) = ".CSV" Then
lngFileFormatNum = 6
ElseIf UCase$(strFileFormat) = ".XLSX" Then
lngFileFormatNum = 51
End If
End Select
On Error GoTo Xit
With rngData
For lngLoop = LBound(varUniques) To UBound(varUniques)
Application.StatusBar = "Processing " & lngLoop & " of " & UBound(varUniques)
If .Parent.FilterMode Then .Parent.ShowAllData
.AutoFilter lngSplitCol, varUniques(lngLoop)
Set rngToCopy = Nothing
Set rngToCopy = .Resize(.Rows.Count, .Columns.Count).SpecialCells(12)
If Not rngToCopy Is Nothing Then
Set wbkNewFile = Workbooks.Add(-4167)
rngToCopy.Copy wbkNewFile.Worksheets(1).Range("a1")
NewFileName = wbkNewFile.Worksheets(1).Range("a2")
If Not blnSplitAllCol Then
For lngLoopCol = UBound(varCols) To 0 Step -1
wbkNewFile.Worksheets(1).Columns(CLng(varCols(lngL oopCol))).Delete
Next
End If
wbkNewFile.SaveAs strOutPutFolder & NewFileName & strFileFormat, lngFileFormatNum
wbkNewFile.Close
Set wbkNewFile = Nothing
End If
Next
.AutoFilter
MsgBox "Done !!", vbInformation, Ttle
End With
End If
Xit:
With Application
.StatusBar = False
.ScreenUpdating = 1
.DisplayAlerts = 1
End With
If Not wbkNewFile Is Nothing Then
wbkNewFile.Close 0
Set wbkNewFile = Nothing
End If

End Sub

[pesteness]

Thank you so much. :cheers: