Solved: Seperate each recipient into own tab

[jsinger]

Hello! Please help! I have many raw data files such as the one attached (Forum Question) and what I want to do is separate each recipient onto its own tab. So the first tab will have all the provider data (first 4 columns) and then the expense for recipient 1 (in column e). The second tab should have the same provider data but this time in column e it should have the data for recipient 2, and so forth (I'll attach the desired result in another thread so you can see).

The files I'm working with have varying numbers of recipients, so I know I need to make a macro that counts the number of recipients and adds that number of sheets (or really, will add that number minus 1, because the first sheet already exists). Then I need it to perform the copying and pasting I described above. I am pretty inexperienced with VBA so am having trouble even getting started. I would really appreciate the help!

Gracias,

Jake

[jsinger]

This is the result I would like to achieve as the result of the macro I am trying to write.

Many thanks.

[adamsm]

Can you describe what you are asking? so that we could understand your problem better.

[Bob Phillips]

[vba]

Public Sub ProcessData()
Dim i As Long
Dim LastRow As Long
Dim LastCol As Long
Dim shName As String

With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 5 To LastCol

shName = .Cells(, i).Value2
.Parent.Worksheets.Add after:=.Parent.Worksheets(.Parent.Worksheets.Count)
ActiveSheet.Name = shName
.Columns("A").Copy .Parent.Worksheets(shName).Range("A1")
.Columns(i).Copy .Parent.Worksheets(shName).Range("E1")
Next i

.Activate
End With

End Sub
[/vba]

[Bob Phillips]

See other post. Don't start a separate thread on the same topic.

[Zack Barresse]

Threads merged. Please keep to one topic per thread. Thank you.

[jsinger]

[vba]

Public Sub ProcessData()
Dim i As Long
Dim LastRow As Long
Dim LastCol As Long
Dim shName As String

With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 5 To LastCol

shName = .Cells(, i).Value2
.Parent.Worksheets.Add after:=.Parent.Worksheets(.Parent.Worksheets.Count)
ActiveSheet.Name = shName
.Columns("A").Copy .Parent.Worksheets(shName).Range("A1")
.Columns(i).Copy .Parent.Worksheets(shName).Range("E1")
Next i

.Activate
End With

End Sub
[/vba]

Hello - many apologies for the duplicate posting (was my first time here). Thank you very much for this code - it worked perfectly in the same document I sent. However, I've tried it in two cases that I have and there are different errors each time. I will try my best to explain.

a) The sample file I posted was a real file, I just replaced all the identifying names and numbers with generic ones. When I try to run this code on the original file (i.e. same amount of rows and columns, just different text), I get an error "400" on after it pastes the first new sheet and creates the second.

b) I tried running the code on a file that had 17 recipients running along the top, rather than 4, and I got the same "400" error after the fourth new sheet was pasted.

I believe the main reason for the error is that sometimes the recipient names are over 31 characters, so do not fit as sheet names. I see the macro is naming the sheets as the recipient name which is great, but not necessary. If it would help, we can have it name the sheets as up to the first 31 characters of the recipient's name? How would I do that?

If you could help me solve these issues I would be extremely happy.

Thanks,
Jake

[jsinger]

Yes I've now confirmed this is the only issue here. And I've tried changing

shName = .Cells(, i).Value2

to

shName = Left(.Cells(, i).Value2, 31)

But the issue is that sometimes two recipients have the same identical first 31 letters.

Any idea how to work around this?

[Bob Phillips]

Try this, it chops out any invalid characters just for good measure

[vba]

Public Sub ProcessData()
Dim i As Long
Dim LastRow As Long
Dim LastCol As Long
Dim shName As String

With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 5 To LastCol

shName = Left$(ValidName(.Cells(, i).Value2), 30)
.Parent.Worksheets.Add after:=.Parent.Worksheets(.Parent.Worksheets.Count)
ActiveSheet.Name = shName
.Columns("A").Copy .Parent.Worksheets(shName).Range("A1")
.Columns(i).Copy .Parent.Worksheets(shName).Range("E1")
Next i

.Activate
End With

End Sub

Function ValidName(ByVal TheFileName As String) As String
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
RegEx.Pattern = "[\\/:\*\?""<>\|]"
RegEx.Global = True
ValidName = RegEx.Replace(TheFileName, "")
Set RegEx = Nothing
End Function
[/vba]

[jsinger]

Try this, it chops out any invalid characters just for good measure

[vba]

Public Sub ProcessData()
Dim i As Long
Dim LastRow As Long
Dim LastCol As Long
Dim shName As String

With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 5 To LastCol

shName = Left$(ValidName(.Cells(, i).Value2), 30)
.Parent.Worksheets.Add after:=.Parent.Worksheets(.Parent.Worksheets.Count)
ActiveSheet.Name = shName
.Columns("A").Copy .Parent.Worksheets(shName).Range("A1")
.Columns(i).Copy .Parent.Worksheets(shName).Range("E1")
Next i

.Activate
End With

End Sub

Function ValidName(ByVal TheFileName As String) As String
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
RegEx.Pattern = "[\\/:\*\?""<>\|]"
RegEx.Global = True
ValidName = RegEx.Replace(TheFileName, "")
Set RegEx = Nothing
End Function
[/vba]

This works beautifully! Well done. However, the last hurdle to clear is that if there are two recipients that have the same 30 or 31 characters (as I've just encountered), a new error pops up telling me I can't have two sheets with the same name. Any ideas how to get around this?

[Bob Phillips]

Just noticed your duplicates bit

[vba]


Public Sub ProcessData()
Dim i As Long
Dim LastRow As Long
Dim LastCol As Long
Dim shName As String
Dim idx As Long

With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 5 To LastCol

idx = 1
shName = Left$(ValidName(.Cells(, i).Value2), 29) & "_" & idx
Do While SheetExists(shName)
idx = idx + 1
shName = Left$(shName, InStrRev(shName, "_")) & idx
Loop
.Parent.Worksheets.Add after:=.Parent.Worksheets(.Parent.Worksheets.Count)
ActiveSheet.Name = shName
.Columns("A").Copy .Parent.Worksheets(shName).Range("A1")
.Columns(i).Copy .Parent.Worksheets(shName).Range("E1")
Next i

.Activate
End With

End Sub

Function ValidName(ByVal TheFileName As String) As String
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
RegEx.Pattern = "[\\/:\*\?""<>\|]"
RegEx.Global = True
ValidName = RegEx.Replace(TheFileName, "")
Set RegEx = Nothing
End Function


'-----------------------------------------------------------------
Function SheetExists(Sh As String, _
Optional wb As Workbook) As Boolean
'-----------------------------------------------------------------
Dim oWs As Worksheet
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
SheetExists = CBool(Not wb.Worksheets(Sh) Is Nothing)
On Error GoTo 0
End Function
[/vba]

[jsinger]

Wow. You are a superstar. I will study this so I can learn how this actually works, but it's spectacular. Thank you so much.

If I may, I was hoping you could answer one quick question. I have a second macro that I use to format each sheet, after they are separated onto new tabs. If possible, I'd like to loop it so that it runs this macro on the first page, scrolls to the next and runs it there, etc..until the last sheet. I know how to loop it to run a macro more than once, but I don't know how to tell it to stop after it reaches the last sheet. Any ideas?

[Bob Phillips]

You don't need to, you can use the For Each ... Next construct.

[vba]

For Each sh In Activeworkbook.Worksheets

If sh.Name <> "Sheet1" then 'avoid our original sheet

'do your stuff oh the sh object
End If
Next sh
[/vba]