Excel Macro to create new individual worksheet on ID

August 20, 2012 at 11:01:03
Specs: Windows XP
I am new to VBA macro programming, so i have been doing trial and error from code that was placed on here earlier that was very similar to what i am trying to do (almost exactly the same)...

I have a project list i am tracking but want to isolate each project's information to its own sheet. (project list is produced via a report.

IntakeID ProjectName ProjectDescription PriorityLevel
2687 Electronically add documents test1 TBD
2776 Docview Retention test2 High
2888 Tracking and Enhancements (Stand Alone) test3 TBD
2889 SBB Hi Watt - Laserpro - LS test4 High

I have the following code, but it is not working past copying in the information into its separate sheet. Ideally i would like to structure the code to be able to paste the individual information to its own sheet, but place the values in certain cells in the new sheet.


record has project ID in A2 cell, description in B2 from report list, but in the new separate sheet, the ID would be in A4, and the description in C3.

Here is what i have (This code was taken from a previous post in which i tried to modify for my purposes, credit goes to whoever started):

Sub CreateProjectSheets()
Dim lastRow, mProjID, tstProjID1, tstProjID2, shtName, nxtRow

On Error Resume Next
'Turn off ScreenUpdating
Application.ScreenUpdating = False
'Make a copy of the data sheet and sort by date
Sheets("Sheet1").Copy After:=Sheets(1)
Sheets(2).Name = "SortTemp"
With Sheets("SortTemp")
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
Rows("2:" & lastRow).Sort Key1:=Range("A2"), Order1:=xlAscending

'Using SortTemp Sheet, create project sheets

'Loop through dates
For Each mProjID In .Range("A2:A" & lastRow)
tstProjID1 = mProjID
tstProjID2 = mProjID.Offset(-1, 0)

'If project IDs are different than cell above, create new sheet
If tstProjID1 <> tstProjID2 Then
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)

'Name the sheet based on the Project ID
ActiveSheet.Name = mProjID
'Copy Column Widths and Header Row
'ActiveSheet.Rows(1).PasteSpecial Paste:=8 'ColumnWidth
'ActiveSheet.Rows(1).PasteSpecial 'Data and Formats
End If
On Error GoTo 0

'Loop through IDs, copying row to the correct sheet
For Each mProjID In .Range("A2:A" & lastRow)
'Create sheetname variable
shtName = mProjID
'Determine next empty row in sheet
nxtRow = Sheets(shtName).Cells(Rows.Count, 1).End(xlUp).Row + 1
'Copy Data
.Range(mProjID.Address).EntireRow.Copy Destination:=Sheets(shtName).Cells(nxtRow, 1)
End With
'Delete SortTemp sheet
Application.DisplayAlerts = False
Application.DisplayAlerts = True
'Turn on ScreenUpdating
Application.ScreenUpdating = True
End Sub

See More: Excel Macro to create new individual worksheet on ID

August 20, 2012 at 12:15:43
Please click on the blue line at the end of this post and, after reading the instructions found via that link, repost your example data and code.


Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.

Report •

February 28, 2013 at 13:23:31
This code was very helpful. Would you be able to adjust the code to truncate the sheet name to max 30 characters? The names from column A (which ultimately become the sheet name) are greater than 31 characters, which is the max lenght of a sheet name. This is causing an error with the report.

Secondly, is there a way to also copy the header from Sheet 1 to each new sheet?

Thank you,

Report •
Related Solutions

Ask Question