VBA Macro to Create Sheets Based on Column of Values
 

Hi everyone,

I have an excel macro that I think is pretty complicated for a newb like me, so I was hoping for some help/guidance

I have 2 sheets:
(1) Carrier - Current Location (attached)
(2) Carrier Specific

Here is what I'm hoping the macro will accomplish:
1) Copy the sheet called Carrier Specific
2) Name the new sheet based on the value in Carrier - Current Location (starting at C4)
3) Input that same value into cell D1 of the new sheet
4) Go down the list in Carrier - Current Location and create new sheets like this until it hits a 0 value

Ex. Carrier - Current Location C4 = CKUO
--I want this to copy Carrier Specific, re-name is CKUO, and input "CKUO" into cell D1 of the new sheet called CKUO
--Then repeat this for every item in the list until it hits a value of 0

I attached my spreadsheet to this as well, please let me know if you can help me out / lead me in the correct direction!
(It's a smaller version of my real workbook, so there's a bunch of REF errors)

Thanks so much!!

VBA Macro to Create Sheets Based on Column of Values
 

Good Afternoon,

This code worked for me on your sample workbook. It uses an input box to have the user select a range with the Carrier names rather than using the ActiveCell approach. This helps ensure that your are running the code only on those cells that you want to create tabs for. Still, it will end the sub upon encountering a "0", so feel free to select the entire range you need if you wish.

To use this, just paste the code below to a module in your sheet. Hope this helps.

Ben

Option Explicit

Sub ParseCarriers()
Dim rCell As Range
Dim rCarriers As Range
Dim wsNew As Worksheet
Dim wsCarriers As Worksheet

On Error Resume Next
Set rCarriers = Application.InputBox("Please select the range of Carrier names to add", "Carrier Selection", , , , , , 8)
If rCarriers Is Nothing Then Exit Sub
On Error GoTo 0

Set wsCarriers = Sheets("Carrier Specific")
Application.ScreenUpdating = False

For Each rCell In rCarriers
If rCell.Value = 0 Then GoTo ExitHere
wsCarriers.Copy After:=Sheets(Sheets.Count)
Set wsNew = ActiveSheet
On Error Resume Next
wsNew.Name = rCell.Value
On Error GoTo 0
wsNew.Range("D1").Value = rCell.Value
Next rCell

ExitHe
Application.ScreenUpdating = True
End Sub