Macro which can create new excel with 4 sheets per different criteria

[jgopalk]

Hi there,

I need a macro which can able to create an excel with 3 sheets based on the following criteria.

Name	Age	Gender	Salary
Ram	25	M	10000
Ganesh	23	M	2000
Saleem	10	M	62300
Antony	26	M	85000
Jebestine	30	M	36900
Sheela	26	F	45630
Karen	96	F	25300
Veni	31	F	63900

<colgroup><col width="64" span="4" style="width:48pt"> </colgroup><tbody>
</tbody>

Here based on the above table, I require a single separate excel with 3 sheets named "Age", "Gender", "Salary". The sheet age must contains Column B red colored text info (the whole row). Gender must contains Column C red color text (the whole row). Salary sheet must contains which there is no color in Column B and C.

Examble.
Age Sheet:

Name	Age	Gender	Salary
Ganesh	23	M	2000
Antony	26	M	85000
Sheela	26	F	45630

<colgroup><col width="64" span="4" style="width:48pt"> </colgroup><tbody>
</tbody>

"Gender" Sheet:

Name	Age	Gender	Salary
Saleem	10	M	62300
Antony	26	M	85000
Sheela	26	F	45630

<colgroup><col width="64" span="4" style="width:48pt"> </colgroup><tbody>
</tbody>

"Salary" Sheet:

Name	Age	Gender	Salary
Ram	25	M	10000
Karen	96	F	25300
Veni	31	F	63900

<colgroup><col width="64" span="4" style="width:48pt"> </colgroup><tbody>
</tbody>

Hope I am clear in what am asking.

Kindly take it as challenge and do this. I tried in many ways, but i couldnt do it.

Thanks,
Gopal

 

[abhi1687]

you can use this:

Sub NewWorkbook()

Dim cel As Range
Workbooks.Add
With ActiveWorkbook
    .SaveAs ThisWorkbook.Path & "\NewWorkbook.xls"
    .Sheets(1).Name = "Age"
    .Sheets(1).Range("A1:D1") = Array("Name", "Age", "Gender", "Salary")
    .Sheets(2).Name = "Gender"
    Sheets(2).Range("A1:D1") = Array("Name", "Age", "Gender", "Salary")
    .Sheets(3).Name = "Salary"
    Sheets(3).Range("A1:D1") = Array("Name", "Age", "Gender", "Salary")
End With
With ThisWorkbook.Sheets("Sheet1")
    For Each cel In .Range(.Range("A2"), .Range("A2").End(xlDown))
        If cel.Offset(, 1).Font.Color = 255 Then cel.EntireRow.Copy ActiveWorkbook.Sheets("Age").Cells(ActiveWorkbook.Sheets("Age").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
        If cel.Offset(, 2).Font.Color = 255 Then cel.EntireRow.Copy ActiveWorkbook.Sheets("Gender").Cells(ActiveWorkbook.Sheets("Gender").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
        If cel.Offset(, 1).Font.Color <> 255 And cel.Offset(, 2).Font.Color <> 255 Then cel.EntireRow.Copy ActiveWorkbook.Sheets("Salary").Cells(ActiveWorkbook.Sheets("Salary").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
    Next
End With

End Sub

in below line change Sheet1 to the sheet name in which your data table is
With ThisWorkbook.Sheets("Sheet1")

 

[jgopalk]

First of all I am terribly sorry for this late reply. I couldn't access my internet due to some issue here. Anyway thank you so much for your reply.

When i save your query and run it, new workbook created with sheet 1 "age" and headers in A1 to D1 with error "Run-time error '9': Subscript out of range". When i click debug the error highlighted in yellow in the code ".Sheets(2).Name = "Gender"". I couldn't understand why this is happening.

Kindly let me know where i went wrong.

Thanks in advance for your time.

Best regards,
Gopal

 

[abhi1687]

Hi Gopal

you must be using excel 2013 or changed the excel options to create new workbook with 1 sheet only. anyways put this line

Application.SheetsInNewWorkbook = 3

before

Workbooks.Add

that should solve your problem

 

[jgopalk]

Its working.


Thank you so much Abhi.


Great work.


Gopal