Solved: New Excel files based on Cell values

[justdream]

Experts,
Please help
I've Original Excel File contains data as in attachement

I need Macro that could (create Different new Excel files) and name it with names matching
with Column A values "without Duplicates"
For Example:
Create Excel file called Company_A
and fill its 1st. coumn with the equivalent Data of Company_A in the original file
x
xx
y
yy
z
zz

Same for Company_B, Company_C

Could you help please?

[BrianMH]

Sub createandcopy()
Dim sPath As String
Dim rng As Range
Dim c1 As Range
Dim c As Range
Dim wb As Workbook
Dim rwBottom As Long
Dim ws As Worksheet
Dim x As Integer
Dim strValue As String
sPath = "C:\Users\Brian\Desktop\" ' set this to where you want the workbooks to be added.
Set rng = Selection
Set c1 = rng.Columns(1)
For Each c In c1.Cells

On Error Resume Next
Set wb = Workbooks(c.Value & ".xlsx")
If wb Is Nothing Then
Set wb = Workbooks.Add
wb.SaveAs (sPath & c.Value)
On Error GoTo 0
End If
Set ws = wb.Sheets(1)
rwBottom = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
If ws.Cells(rwBottom, 1).Value <> "" Then
rwBottom = rwBottom + 1
End If
For x = 1 To rng.Columns.Count - 1
ws.Cells(rwBottom, x).Value = c.Offset(, x).Value
Next
If strValue <> c.Value Then
strValue = c.Value
wb.Save
End If
Set wb = Nothing
Next

End Sub



This code works based on selection. So if you wanted to have extra columns of information it will work. You will need to set your path. It uses the first column of your selection as names for the workbooks and the rest of the columns it puts into the workbooks. It also assumes that the workbooks do not already exists or are open. If they already exist but are not open they will be overwritten.

[justdream]

[quote=BrianMH
This code works based on selection. So if you wanted to have extra columns of information it will work. You will need to set your path. It uses the first column of your selection as names for the workbooks and the rest of the columns it puts into the workbooks. It also assumes that the workbooks do not already exists or are open. If they already exist but are not open they will be overwritten.[/quote]

Dear Friend,

Please help..
- Your code Never stop, repetitive
- Secondly code create different excel file for each element in Column B (I'd to have one excel file for all cells in column B that have same Company in Column A)

These are the most important..
It will be amazing, if Macro could save All new created files to one Path
plus closing it

I highly appreciate your help, Thanks

[BrianMH]

Did you select column a and b and only the cells with values? I'm on my way to work now but when I get a chance I will have a look. If in the meantime anyone wants to have a go I don't mind. To be honest I was tired last night. Saying that it does work following the instructions. Which version of excel are you using?

Posted from my android

[BrianMH]

Option Explicit
Sub createandcopy()
Dim sPath As String
Dim rng As Range
Dim c1 As Range
Dim c As Range
Dim wb As Workbook
Dim rwBottom As Long
Dim ws As Worksheet
Dim x As Integer
Dim strValue As String
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
sPath = "C:\Documents and Settings\b7385\Desktop\" ' set this to where you want the workbooks to be added.
Set ws = ThisWorkbook.Sheets(1)
rwBottom = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("A2:A" & rwBottom)
For Each c In rng.Cells
On Error Resume Next
Set wb = Workbooks(c.Value & ".xls")
If wb Is Nothing Then
If Not fso.fileexists(sPath & c.Value & ".xls") Then
Set wb = Workbooks.Add
wb.SaveAs Filename:=sPath & c.Value & ".xls", FileFormat:=xlExcel8
Else
Set wb = Workbooks.Open(sPath & c.Value & ".xls")
End If
End If

Set ws = wb.Sheets(1)
rwBottom = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
If ws.Cells(rwBottom, 1).Value <> "" Then
rwBottom = rwBottom + 1
End If
For x = 1 To 1
ws.Cells(rwBottom, x).Value = c.Offset(, x).Value
Next
Set wb = Nothing
Next c
For Each wb In Workbooks
If wb.Name <> ThisWorkbook.Name Then
wb.Save
wb.Close (False)
End If
Next


End Sub


I had a chance to update this. This should do exactly what you want but with no selection needed. Keep in mind it closes all open workbooks except the workbook the code is in so you don't want any extra workbooks open. If you need to add columns change For x = 1 To 1 to the number of columns after column 1 you need.

[justdream]

Excellent, my friend
You have saved 10s of dumm workign hours

[justdream]

Dear Friend,

Just one more favour please: could we let Main Row header to be included in all new sheets

Hint: I mean that first Header that contains Description "I'd like this to be also copied in all new sheets"

[BrianMH]

Option Explicit
Sub createandcopy()
Dim sPath As String
Dim rng As Range
Dim c1 As Range
Dim c As Range
Dim wb As Workbook
Dim rwBottom As Long
Dim ws As Worksheet
Dim x As Integer
Dim strValue As String
Dim fso
Dim iColumns As Integer
iColumns = 1
Set fso = CreateObject("Scripting.FileSystemObject")
sPath = "C:\Users\Brian\Desktop\" ' set this to where you want the workbooks to be added.
Set ws = ThisWorkbook.Sheets(1)
rwBottom = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("A2:A" & rwBottom)
For Each c In rng.Cells
On Error Resume Next
Set wb = Workbooks(c.Value & ".xls")
If wb Is Nothing Then
If Not fso.fileexists(sPath & c.Value & ".xls") Then
Set wb = Workbooks.Add
wb.SaveAs Filename:=sPath & c.Value & ".xls", FileFormat:=xlExcel8
Else
Set wb = Workbooks.Open(sPath & c.Value & ".xls")
End If
End If

Set ws = wb.Sheets(1)
rwBottom = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
If ws.Cells(rwBottom, 1).Value = "" And rwBottom = 1 Then
For x = 2 To iColumns + 1
ws.Cells(rwBottom, x - 1).Value = c.Worksheet.Cells(rwBottom, x).Value
Next

End If
rwBottom = rwBottom + 1
For x = 1 To iColumns
ws.Cells(rwBottom, x).Value = c.Offset(, x).Value
Next
Set wb = Nothing
Next c
For Each wb In Workbooks
If wb.Name <> ThisWorkbook.Name Then
wb.Save
wb.Close (False)
End If
Next


End Sub


there you go. Now you need to define iColumns at the top to the number of columns.

[justdream]

Dear Friend,

New code is not working, always give me message for saving Excel files but nothing have been saved or opened

Kindly check, if you are not too much busy :help

Also I see that New code only Copy Main Header "Destination"
and below just one value
while below all values belong to Company_A should be copied in one Excel, same for Company_B, Same for Company_C

Thanks in advance

[justdream]

Sorry, it's working perfectly
it was my mistake

as I've entered new Path to save my Data without ending it with \

Million Thanks