Split table into different workbooks

[_Gandour_]

Hello guys, i have table with different projects on each row. i need to create a sheet for each row/project mantaining the title row and naming each new workbook as the project name. Is there a way to do it in vba, im really new to this :/

Example:

Original workbook

ProjectCode ProjectName Objective Manager
111 AAA BBB CCC
222 DDD EEE FFF

New Workbook (name: AAA)

ProjectCode ProjectName Objective Manager
111 AAA BBB CCC

New Workbook (name: DDD)

ProjectCode ProjectName Objective Manager
222 DDD EEE FFF



Would Apreciate n help

Thanks in advance.

 

[rpaulson]

try this.

Sub Create_xls_File_p1()
Dim Mypath As String
Mypath = Environ("USERPROFILE") & "\Desktop\"

lr = Range("A" & Rows.Count).End(xlUp).Row
For r = 2 To lr

myfile = Mypath & Cells(r, "B") & ".xlsx"
Rows(r).Copy
Set NewBook = Workbooks.Add
  
NewBook.Worksheets("Sheet1").Range("A2").Select
ActiveSheet.Paste

Range("A1:D1").Value = [{"ProjectCode","ProjectName","Objective","Manager"}]
  
NewBook.SaveAs Filename:=myfile 
ActiveWorkbook.Close
Next r

End Sub

hth,

Ross

 

[_Gandour_]

try this.

Sub Create_xls_File_p1()
Dim Mypath As String
Mypath = Environ("USERPROFILE") & "\Desktop\"

lr = Range("A" & Rows.Count).End(xlUp).Row
For r = 2 To lr

myfile = Mypath & Cells(r, "B") & ".xlsx"
Rows(r).Copy
Set NewBook = Workbooks.Add
  
NewBook.Worksheets("Sheet1").Range("A2").Select
ActiveSheet.Paste

Range("A1:D1").Value = [{"ProjectCode","ProjectName","Objective","Manager"}]
  
NewBook.SaveAs Filename:=myfile 
ActiveWorkbook.Close
Next r

End Sub

hth,

Ross

Hey Ross, unfortunately your code gave me "Subscript out of Range" Error. My only change to your code was in the range criteria to allow the real names of the sheet

Sub Create_xls_File_p1()
Dim Mypath As String
Mypath = Environ("USERPROFILE") & "\Desktop\"


lr = Range("A" & Rows.Count).End(xlUp).Row
For r = 2 To lr


myfile = Mypath & Cells(r, "B") & ".xlsx"
Rows(r).Copy
Set NewBook = Workbooks.Add
  
NewBook.Worksheets("Sheet1").Range("A2").Select
ActiveSheet.Paste


Range("A1:G1").Value = [{"Código","Projeto","Servidor Solicitante","Finalidade","Justificativas","Gerente de Projeto","Data de Início de Projeto"}]
  
NewBook.saveas Filename:=myfile
ActiveWorkbook.Close
Next r


End Sub

 

[rpaulson]

you code is working for me.

Send me you file.

I PM you me email

 

[_Gandour_]

sent it