Create New tabs based on cell value

babar2019 · Aug 12, 2019

HI,

I have an excel with 2 columns.
Column A = Name
Column B = 'URL' (www.google.com)

Not all Column A's have URL field. some are blank.

I want to create new tabs in the same excel and seperate out URL and NO URL data.

Please advise.

ekrause · Aug 12, 2019

Hi!

For this you will want to create your "No URL" and "URL" tabs beforehand. I put column headers in A1 and B1 which you will also need to do if you want to use this code without changes. I also used a named range to designate the start of the data (the name column) as "DataStart". You can either name your range the same or change the "Set NameLoop =" below to match your desired selection. This assumes there are no gaps or spaces between names.

Let me know if you have any questions or snags.

Code:

Set NameLoop = Range(Range("DataStart"), Range("DataStart").End(xlDown))

For Each NameCell In NameLoop


    If NameCell.Offset(0, 1) = "" Then
        If Sheets("No URL").Range("A1").Offset(1) = "" Then
            Sheets("No URL").Range("A1").Offset(1) = NameCell
            Sheets("No URL").Range("A1").Offset(1, 1) = NameCell.Offset(0, 1)
        Else
            Sheets("No URL").Range("A1").End(xlDown).Offset(1) = NameCell
            Sheets("No URL").Range("A1").End(xlDown).Offset(0, 1) = NameCell.Offset(0, 1)
        End If
    Else
        If Sheets("URL").Range("A1").Offset(1) = "" Then
            Sheets("URL").Range("A1").Offset(1) = NameCell
            Sheets("URL").Range("A1").Offset(1, 1) = NameCell.Offset(0, 1)
        Else
            Sheets("URL").Range("A1").End(xlDown).Offset(1) = NameCell
            Sheets("URL").Range("A1").End(xlDown).Offset(0, 1) = NameCell.Offset(0, 1)
        End If
    End If


Next NameCell

JoeMo · Aug 12, 2019

This will create new sheets named "URL" and "NoURL" each time it is run from the source data sheet. Source data assumed to be in cols A & B with headers in A1:B1.

Code:

Sub SeperateTabs()
'run from source data sheet
'assumes headers in A1 (names) and B1 (URL)
Dim dataSht As Worksheet, R As Range, Temp As Range
Set dataSht = ActiveSheet
Set R = Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row)
Application.ScreenUpdating = False
R.AutoFilter field:=2, Criteria1:="<>"
On Error Resume Next
Set Temp = R.SpecialCells(xlCellTypeVisible)
If Err.Number = 0 Then
    Application.DisplayAlerts = False
    Sheets("URL").Delete
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = "URL"
    Temp.Copy Destination:=Sheets("URL").Range("A1")
End If
Err.Clear
R.AutoFilter field:=2, Criteria1:="="
On Error Resume Next
Set Temp = R.SpecialCells(xlCellTypeVisible)
If Err.Number = 0 Then
    Application.DisplayAlerts = False
    Sheets("NoURL").Delete
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = "NoURL"
    Temp.Copy Destination:=Sheets("NoURL").Range("A1")
End If
Err.Clear
With dataSht
    .Select
    .ShowAllData
End With
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With
End Sub

babar2019 · Aug 13, 2019

Hi JoeMo,

Thanks for your response The code worked really good.

Just few requests,

1. Is it possible to get additional columns when copying over data. Right now it just gets A&B. I need A through G.
2. For every name in Process A, can the code create a URL and No URL tabs for every individual name and seperate URL & No URL data?

For example, let's say we have the below data: The code should create tabs for "2CP - URL" & "2CP - NO URL" and send 1st 2 rows into URL and 3rd row to No URL tabs. Then repeat the same process for AMS. It should follow this process for every unique name in Column A.

ISO	URL	Merchant DBA
2CP	www.test.com	Apple
2CP	www.test.com	Orange
2CP		Banana
AMS	www.test.com	Grapes
AMS	www.test.com	Pineapple
AMS		Mango

JoeMo · Aug 13, 2019

babar2019 said:
Hi JoeMo,

Thanks for your response The code worked really good.

Just few requests,

1. Is it possible to get additional columns when copying over data. Right now it just gets A&B. I need A through G.
2. For every name in Process A, can the code create a URL and No URL tabs for every individual name and seperate URL & No URL data?

For example, let's say we have the below data: The code should create tabs for "2CP - URL" & "2CP - NO URL" and send 1st 2 rows into URL and 3rd row to No URL tabs. Then repeat the same process for AMS. It should follow this process for every unique name in Column A.

ISO URL Merchant DBA
2CP www.test.com Apple
2CP www.test.com Orange
2CP Banana
AMS www.test.com Grapes
AMS www.test.com Pineapple
AMS Mango

<tbody>
</tbody>

You are welcome - thanks for the reply.

As for your 2 new requests, the modified code below addresses request 1. Request 2 requires more extensive modification and willl take some time which I'm a bit short on right now. I will try to address request 2 when time permits.

Code:

Sub SeperateTabs()
'run from source data sheet
'assumes headers in A1 (names) and B1 (URL) and data in cols A:G
Dim dataSht As Worksheet, R As Range, Temp As Range
Set dataSht = ActiveSheet
Set R = Range("A1:G" & Cells(Rows.Count, "A").End(xlUp).Row)
Application.ScreenUpdating = False
R.AutoFilter field:=2, Criteria1:="<>"
On Error Resume Next
Set Temp = R.SpecialCells(xlCellTypeVisible)
If Err.Number = 0 Then
    Application.DisplayAlerts = False
    Sheets("URL").Delete
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = "URL"
    Temp.Copy Destination:=Sheets("URL").Range("A1")
End If
Err.Clear
R.AutoFilter field:=2, Criteria1:="="
On Error Resume Next
Set Temp = R.SpecialCells(xlCellTypeVisible)
If Err.Number = 0 Then
    Application.DisplayAlerts = False
    Sheets("NoURL").Delete
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = "NoURL"
    Temp.Copy Destination:=Sheets("NoURL").Range("A1")
End If
Err.Clear
With dataSht
    .Select
    .ShowAllData
End With
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With
End Sub

JoeMo · Aug 13, 2019

Managed to find a bit of time for this. This should produce the results you want for both Requests 1 & 2.

Code:

Sub SeperateTabs2()
'run from source data sheet
'assumes headers in A1 (ISO) and B1 (URL) and data in cols A:G
'creates URL and No URL sheets for each unique ISO entry
Dim dataSht As Worksheet, R As Range, Iso As Variant, d As Object, c As Range, Temp As Range
Set dataSht = ActiveSheet
Set R = Range("A1:G" & Cells(Rows.Count, "A").End(xlUp).Row)
'get unique list from col A ISOs
Set d = CreateObject("scripting.dictionary")
For Each c In R.Columns(1).Cells
    If Not d.exists(c.Value) Then d.Add c.Value, d.Count + 1
Next c
Application.ScreenUpdating = False
For i = 1 To d.Count - 1
    R.AutoFilter field:=1, Criteria1:=d.keys()(i)
    R.AutoFilter field:=2, Criteria1:="<>"
    On Error Resume Next
    Set Temp = R.SpecialCells(xlCellTypeVisible)
    If Err.Number = 0 Then
        Application.DisplayAlerts = False
        Sheets(d.keys()(i) & " - URL").Delete
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = d.keys()(i) & " - URL"
        Temp.Copy Destination:=ActiveSheet.Range("A1")
    End If
    Err.Clear
    R.AutoFilter field:=1, Criteria1:=d.keys()(i)
    R.AutoFilter field:=2, Criteria1:="="
    On Error Resume Next
    Set Temp = R.SpecialCells(xlCellTypeVisible)
    If Err.Number = 0 Then
        Application.DisplayAlerts = False
        Sheets(d.keys()(i) & " - NoURL").Delete
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = d.keys()(i) & " - NoURL"
        Temp.Copy Destination:=ActiveSheet.Range("A1")
    End If
    Err.Clear
Next i
With dataSht
    .Select
    .ShowAllData
End With
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With
End Sub

babar2019 · Aug 14, 2019

Awesome. Thanks a lot.

Just for future reference: Right now we are taking column B as URL. If this column changes in the future, which part of the code do I modify to reference the right column?

Also, can the code check to see if the ISO needs a URL or No URL tab ? example, some of the ISO's definitely have URL's in the data, In this case we really don't need the NO URL tab and vice versa.

Thanks in advance for your time. Really appreciate that.

JoeMo · Aug 14, 2019

babar2019 said:
Awesome. Thanks a lot.

Just for future reference: Right now we are taking column B as URL. If this column changes in the future, which part of the code do I modify to reference the right column?

Also, can the code check to see if the ISO needs a URL or No URL tab ? example, some of the ISO's definitely have URL's in the data, In this case we really don't need the NO URL tab and vice versa.

Thanks in advance for your time. Really appreciate that.

You are welcome - thanks for the reply.

The only thing you need to change if the URL column changes is the field number of the autofilters. Field:= 2 is column B, if the URLs change to col C, and cols A & B are still used it would be Field:= 3.

Here's a modification which restricts new tabs to URL and NoURL for only those ISOs that have either URLs or blanks in col B.

Code:

Sub SeperateTabs3()
'run from source data sheet
'assumes headers in A1 (ISO) and B1 (URL) and data in cols A:G
'creates URL and No URL sheets for each unique ISO entry
Dim dataSht As Worksheet, R As Range, Iso As Variant, d As Object, c As Range, Temp As Range
Set dataSht = ActiveSheet
Set R = Range("A1:G" & Cells(Rows.Count, "A").End(xlUp).Row)
'get unique list from col A ISOs
Set d = CreateObject("scripting.dictionary")
For Each c In R.Columns(1).Cells
    If Not d.exists(c.Value) Then d.Add c.Value, d.Count + 1
Next c
Application.ScreenUpdating = False
For i = 1 To d.Count - 1
    R.AutoFilter field:=1, Criteria1:=d.keys()(i)
    R.AutoFilter field:=2, Criteria1:="<>"
    On Error Resume Next
    Set Temp = R.SpecialCells(xlCellTypeVisible)
    If Err.Number = 0 Then
        If Temp.Areas.Count > 1 Or Temp.Rows.Count > 1 Then
            Application.DisplayAlerts = False
            Sheets(d.keys()(i) & " - URL").Delete
            Sheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = d.keys()(i) & " - URL"
            Temp.Copy Destination:=ActiveSheet.Range("A1")
        End If
    End If
    Err.Clear
    R.AutoFilter field:=1, Criteria1:=d.keys()(i)
    R.AutoFilter field:=2, Criteria1:="="
    On Error Resume Next
    Set Temp = R.SpecialCells(xlCellTypeVisible)
    If Err.Number = 0 Then
        If Temp.Areas.Count > 1 Or Temp.Rows.Count > 1 Then
            Application.DisplayAlerts = False
            Sheets(d.keys()(i) & " - NoURL").Delete
            Sheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = d.keys()(i) & " - NoURL"
            Temp.Copy Destination:=ActiveSheet.Range("A1")
        End If
    End If
    Err.Clear
Next i
With dataSht
    .Select
    .ShowAllData
End With
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With
End Sub

babar2019 · Aug 15, 2019

Awesome. Works perfect!!! Thanks for your time

JoeMo · Aug 15, 2019

babar2019 said:
Awesome. Works perfect!!! Thanks for your time

You are welcome - thanks for the reply.

Create New tabs based on cell value

babar2019

Board Regular

Excel Facts

ekrause

Board Regular

JoeMo

MrExcel MVP

babar2019

Board Regular

JoeMo

MrExcel MVP

JoeMo

MrExcel MVP

babar2019

Board Regular

JoeMo

MrExcel MVP

babar2019

Board Regular

JoeMo

MrExcel MVP

Similar threads

Forum statistics

Share this page

Create New tabs based on cell value

Board Regular

Excel Facts

Board Regular

MrExcel MVP

Board Regular

MrExcel MVP

MrExcel MVP

Board Regular

MrExcel MVP

Board Regular

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock