Create New tabs based on cell value

[babar2019]

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]

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.

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]

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.

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]

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.

[TABLE="width: 821"]
<colgroup><col><col><col></colgroup><tbody>[TR]
[TD]ISO[/TD]
[TD]URL[/TD]
[TD]Merchant DBA[/TD]
[/TR]
[TR]
[TD]2CP[/TD]
[TD]www.test.com[/TD]
[TD]Apple[/TD]
[/TR]
[TR]
[TD]2CP[/TD]
[TD]www.test.com[/TD]
[TD]Orange[/TD]
[/TR]
[TR]
[TD]2CP[/TD]
[TD][/TD]
[TD]Banana[/TD]
[/TR]
[TR]
[TD]AMS[/TD]
[TD]www.test.com[/TD]
[TD]Grapes[/TD]
[/TR]
[TR]
[TD]AMS[/TD]
[TD]www.test.com[/TD]
[TD]Pineapple[/TD]
[/TR]
[TR]
[TD]AMS[/TD]
[TD][/TD]
[TD]Mango[/TD]
[/TR]
</tbody>[/TABLE]

 

[JoeMo]

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.

[TABLE="width: 821"]
<tbody>[TR]
[TD]ISO[/TD]
[TD]URL[/TD]
[TD]Merchant DBA[/TD]
[/TR]
[TR]
[TD]2CP[/TD]
[TD]www.test.com[/TD]
[TD]Apple[/TD]
[/TR]
[TR]
[TD]2CP[/TD]
[TD]www.test.com[/TD]
[TD]Orange[/TD]
[/TR]
[TR]
[TD]2CP[/TD]
[TD][/TD]
[TD]Banana[/TD]
[/TR]
[TR]
[TD]AMS[/TD]
[TD]www.test.com[/TD]
[TD]Grapes[/TD]
[/TR]
[TR]
[TD]AMS[/TD]
[TD]www.test.com[/TD]
[TD]Pineapple[/TD]
[/TR]
[TR]
[TD]AMS[/TD]
[TD][/TD]
[TD]Mango[/TD]
[/TR]
</tbody>[/TABLE]

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.

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]

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

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]

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]

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.

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]

Awesome. Works perfect!!! Thanks for your time

 

[JoeMo]

Awesome. Works perfect!!! Thanks for your time

You are welcome - thanks for the reply.