Create new worksheet for each unique value in a list

This quick script will go down column A of a tab named ‘Data’ and for each unique value it finds, it will create a worksheet with that name and then for each occurrence of the value in the list it will populate the new sheet line by line with the data alongside the value in columns B – G.


Application.ScreenUpdating = False

TM = Now()

'Find the lastrow in the main worksheet
With Worksheets("Data")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

'This bit adds a new sheet for each FE it recognises, using the error trap to not create it if it's already there
For fe = 2 To lastrow

'Where FE Name is empty, create a NULL entry so as to not error
If Worksheets("Data").Range("A" & fe) = "" Then Worksheets("Data").Range("A" & fe) = "NULL"

If Len(Worksheets("Data").Range("A" & fe)) < 32 Then FE_Name = Worksheets("Data").Range("A" & fe) End If If Len(Worksheets("Data").Range("A" & fe)) > 31 Then
FE_Name = Left(Worksheets("Data").Range("A" & fe), 31)
End If

'FE_Name = Worksheets("Data").Range("A" & fe)

On Error GoTo ErrHandler:
Worksheets(FE_Name).Activate
Worksheets(FE_Name).Range("A2:Z10000").ClearContents

ErrHandler:
If Err.Number = 9 And FE_Name <> "" Then
' sheet does not exist, so create it
Worksheets.Add.Name = FE_Name

'Set the column widths and title / initial headers as well as format them as required.
With Worksheets(FE_Name)
.Columns("A:A").ColumnWidth = 26
.Columns("B:B").ColumnWidth = 21
.Columns("C:C").ColumnWidth = 93
.Range("A1") = "Header 1"
.Range("A1").Font.Bold = True
.Range("A1").BorderAround xlContinuous
.Range("B1") = "Header 2"
.Range("B1").Font.Bold = True
.Range("B1").BorderAround xlContinuous
.Range("c1") = "Header 3"
.Range("C1").Font.Bold = True
.Range("C1").BorderAround xlContinuous
.Range("D1") = "Header 4"
.Range("D1").Font.Bold = True
.Range("D1").BorderAround xlContinuous
.Range("E1") = "Header 5"
.Range("E1").Font.Bold = True
.Range("E1").BorderAround xlContinuous
.Range("F1") = "Header 6"
.Range("F1").Font.Bold = True
.Range("F1").BorderAround xlContinuous
.Range("G1") = "Header 7"
.Range("G1").Font.Bold = True
.Range("G1").BorderAround xlContinuous
End With
' go back to the line of code that caused the problem
Resume
End If

Next fe

'Need to build each sheet with the FE exceptions if any
'Again, loop down the Sheet1 tab and grab FE name from F and if BI > 0 then scan across and fire the info into the FE tab
'in the structured manner

For N = 2 To lastrow
Application.StatusBar = N

If Len(Worksheets("Data").Range("A" & N)) < 32 Then FE_Name = Worksheets("Data").Range("A" & N) End If If Len(Worksheets("Data").Range("A" & N)) > 31 Then
FE_Name = Left(Worksheets("Data").Range("A" & N), 31)
End If

HDR1 = Worksheets("Data").Range("B" & N)
HDR2 = Worksheets("Data").Range("C" & N)
HDR3 = Worksheets("Data").Range("D" & N)
HDR4 = Worksheets("Data").Range("E" & N)
HDR5 = Worksheets("Data").Range("F" & N)
HDR6 = Worksheets("Data").Range("G" & N)
HDR7 = Worksheets("Data").Range("H" & N)

With Worksheets(FE_Name)
lastrowFE = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & lastrowFE) = Worksheets("Data").Range("A" & N)
.Range("B" & lastrowFE) = HDR1
.Range("C" & lastrowFE) = HDR2
.Range("D" & lastrowFE) = HDR3
.Range("E" & lastrowFE) = HDR4
.Range("F" & lastrowFE) = HDR5
.Range("G" & lastrowFE) = HDR6
.Range("H" & lastrowFE) = HDR7
End With

Next N

'Clean it all up

'Move the Main and Data tabs back to the beginning

Sheets("Data").Move Before:=Sheets(1)
Sheets("main").Move Before:=Sheets(1)
TM2 = Now()

MsgBox TM & vbNewLine & TM2






Contact us for some advice and guidance on how your Excel development could be created and start helping your business straight away. Contact Us

Datanology