Copy and Create New Worksheet Tabs from Column Values

[wazzulu1]

Hi;

Is it possible to create new worksheet tabs in a worksheet, based off of column values, say in column G.

So that a macro would look through column G, and create a tab for each unique value, then copy the rows from column A:AS to the new sheet that is associated with that value?

I'm still a newbie needing help.

Thanks!

 

[acw]

Hi

How about

Sub ccc()
  Set dic = CreateObject("scripting.dictionary")
  For Each ce In Range("G1:G" & Cells(Rows.Count, "G").End(xlUp).Row)
    If Not dic.exists(ce.Value) Then
      dic.Add ce.Value, ce.Value
      Sheets.Add after:=Worksheets(Sheets.Count)
      ActiveSheet.Name = ce.Value
      Range("A1").Resize(1, 29).Value = Sheets("sheet1").Cells(ce.Row, 1).Resize(1, 29).Value
    End If
  Next ce
  
End Sub

Tony

 

[wazzulu1]

Hi Tony;

Do I need to reference the sheet name on this line of the macro?

ActiveSheet.Name = ce.Value


The debugger stopped me at this point when I tried to execute it.

 

[acw]

Hi

Shouldn't need to. I started with a single sheet workbook with the data in column G.

Are you sure the sheet for that name didn't already exist?


Tony

 

[wazzulu1]

I think the problem may be that a value does not appear until row 11.

The run time error code was 1004


Also, I need all the rows associated with that value to be copied in each sheet.

 

[agihcam]

Hi -
try this long code but will work maybe.( save as the file for testing )
this code will do the following;
1. create unique list in columnIV from columnG of sheet1
2. delete existing sheets from sheets2 to sheets.count
3. create new sheet from unique list in columnIV
4. loop thru each sheet and find the sheetname from sheets1 columnG
5. paste the row data to each sheet.

Sub sample()
Dim i As Long
Application.ScreenUpdating = False

'create unique list
Sheets(1).Columns("G").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
    "IV1"), Unique:=True
    
'delete sheets
For i = 2 To Sheets.Count
    Application.DisplayAlerts = False
    Sheets(2).Delete
    Application.DisplayAlerts = True
Next

'create new sheets
With Sheets(1)
    For i = 2 To .Range("iv" & Rows.Count).End(xlUp).Row
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = .Cells(i, "iv").Value
    Next
End With
Sheets(1).Columns("iv").ClearContents
    
'gather data
For i = 2 To Sheets.Count
n = 2
    With Sheets(1).Columns("g")
        Set c = .Find(Sheets(i).Name, , , xlWhole)
            If Not c Is Nothing Then
                f = c.Address
                Do
                    Application.CutCopyMode = False
                    c.EntireRow.Copy
                        With Sheets(i).Range("a" & n)
                            .PasteSpecial xlValues
                        End With
                    Application.CutCopyMode = True
                Set c = .FindNext(c)
                n = n + 1
                Loop Until f = c.Address
                
            End If
    End With
Next
Application.ScreenUpdating = True
End Sub

 

[wazzulu1]

I have existing tabs with other data, it wiped them out.....


There are 10 existing tabs, the first is "Customer File" that the data is to be copied from

 

[agihcam]

ok how many are those existing tabs and what is the sheet name for the data you want to copy into individual sheet?

 

[acw]

Hi

Ok try

Sub ccc()
  Set dic = CreateObject("scripting.dictionary")
  For Each ce In Range("G11:G" & Cells(Rows.Count, "G").End(xlUp).Row)
    If Not dic.exists(ce.Value) Then
      dic.Add ce.Value, ce.Value
      Sheets.Add after:=Worksheets(Sheets.Count)
      ActiveSheet.Name = ce.Value
      Range("A1").Resize(1, 29).Value = Sheets("sheet1").Cells(ce.Row, 1).Resize(1, 29).Value
    Else
      With Sheets(ce.Value)
        .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 29).Value = Sheets("sheet1").Cells(ce.Row, 1).Resize(1, 29).Value
      End With
    End If
  Next ce
  
End Sub

It assumes that the data starts in G11, there are no blank entries, and there are no existing sheets that match the name in G11 at the start of the run.

Tony

 

[wazzulu1]

The debugger stopped the macro on this part of the code:

Range("A1").Resize(1, 29).Value = Sheets("sheet1").Cells(ce.Row, 1).Resize(1, 29).Value