looping to test for new part # 1

[Mack2]

I need to create a new worksheet tab for each unique part number (first column). So when a new part appears, it should grab that row, and insert a new tab with the part number being the name of the worksheet. Does anyone have an idea how to do this? THANKS!!!!!!!!

G1B10008-010 G1BPPRD 08/28/06 121192806
G1B10008-010 G1BPPRD 08/28/06 121192806
G1B10008-011 G1BPPRD 08/28/06 121192806
G1B10008-011 G1BPPRD 08/28/06 121192806
G1B10008-011 G1BPPRD 08/28/06 121192806
G1B10008-012 G1BPPRD 08/28/06 121192806
G1B10008-012 G1BPPRD 08/28/06 121192806

 

[HarleyQuinn]

This should be a fairly simple order on part number, loop through the cells, check if the value is different than the previous and if it is, create a new sheet named as the value of the cell.

What have you tried so far?

HarleyQuinn
---------------------------------
Get the most out of Tek-Tips, read FAQ222-2244 before posting.

 

[Mack2]

For Each cell In Range("e1:e20")
If cell.Value = cell.Offset(1, 0).Value Then
cell.Offset(0, 2).Copy
MsgBox "Same value detected in cells" & " " & Selection.Address & " & " & cell.Offset(0, 1).Address, vbOKOnly
Else
Sheets.Add
Range("F5").Select
cell.PasteSpecial

Exit Sub

 

[HarleyQuinn]

Hi,

Here is a quick modification of your code to loop through the (currently hardcoded) range of cells and create a new sheet based on each unique value in the first column.

It's not the best code I've ever done, but it should get you started anyway.

You will be able to add any copying of values etc. in yourself around the code.

Sub Test()

'Cells.Select 'Can be used but not necessary, if used change Cells.Sort to Selection.Sort below

Cells.Sort Key1:=Range("E1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

Sheets.Add , Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Sheets(1).Cells(1, 5).Value

For Each cell In Sheets(1).Range("E2:E20")
If cell.Value <> cell.Offset(-1, 0).Value Then
Sheets.Add , Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = cell.Value
End If
Next cell

MsgBox "Done!"

End Sub

Hope this helps

HarleyQuinn
---------------------------------
Get the most out of Tek-Tips, read FAQ222-2244 before posting.

 

[Mack2]

THAT WORKED!!! Thanks! I had to make a couple of tweaks, but it is creating the tabs perfectly! Thanks again!

For Each cell In Sheets(1).Range("E2:E140")
If cell.Value <> cell.Offset(-1, 0).Value Then
Selection.Offset(0, 2).Select
Selection.Copy
Sheets.Add , Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = cell.Value
ActiveSheet.Select
ActiveSheet.Paste

End If

Next cell

 

[HarleyQuinn]

Glad I could help, thanks for the star

HarleyQuinn
---------------------------------
Get the most out of Tek-Tips, read FAQ222-2244 before posting.