Macro to automate task...

[Guest]

Hello

I am working with a worksheet in Excel, and one of the fields (columns) in
the worksheet is "TEAM". I have to replicate the spreadsheet for each team,
and at the moment I am creating a copy of the spreadsheet, then using the
auto filter to filter on a team, renaming the worksheet to the name of that
team, and then repeating this process for each of the teams.

Is there a way of automating this task, so that I create a worksheet for
each team using the main worksheet that has all the teams listed?

Hope this makes sense - any assistance would be greatly appreciated.

Thanks in advance

AC

 

[Bob Phillips]

Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long
Dim iLastRow As Long
Dim iRow As Long
Dim sh As Worksheet

With ActiveSheet

iLastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = 2 To iLastRow
Set sh = Nothing
On Error Resume Next
Set sh = Worksheets(.Cells(i, TEST_COLUMN).Value)
On Error GoTo 0
If sh Is Nothing Then
Set sh = Worksheets.Add
sh.Name = .Cells(i, TEST_COLUMN).Value
.Rows(1).Copy sh.Range("A1")
iRow = 2
Else
iRow = sh.Cells(sh.Rows.Count, TEST_COLUMN).End(xlUp).Row
iRow = iRow + 1
End If
.Rows(i).Copy sh.Range("A" & iRow)
Next i
.Activate
End With

End Sub

--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Guest]

Hello Bob

Thank you very much for your help with this!
It works wonderfully!

Much appreciated
AC

 

[Max]

A very useful sub, Bob !
Thanks

---

 

[Max]

Bob,

How could your sub be modified to handle cases where TEST_COLUMN might
contain:

1. blank cells
2. null string returns by formulas
3. error returns (any kind) by formulas

Let's say I want the spliced sheets to be named as, correspondingly:

1. Blank
2. NS
3. Err

(there's data in other cols to be returned for each of the above values)

For the above instances, the sub currently stops at this line:
sh.Name = .Cells(i, TEST_COLUMN).Value

Thanks

---

 

[Bob Phillips]

This should do it Max.

I have marked the changes so that you follow it through

Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long
Dim iLastRow As Long
Dim iRow As Long
Dim sh As Worksheet
Dim shName As String '<<<<< new variable

With ActiveSheet

iLastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = 2 To iLastRow
'<<<<< new code .............................
If IsError(.Cells(i, TEST_COLUMN).Value) Then
shName = "Err"
ElseIf .Cells(i, TEST_COLUMN).Value = "" Then
If .Cells(i, TEST_COLUMN).HasFormula Then
shName = "NS"
Else
shName = "Blanks"
End If
Else
shName = .Cells(i, TEST_COLUMN).Value
End If
'<<<<< end of new code .......................
Set sh = Nothing
On Error Resume Next
Set sh = Worksheets(shName) '<<<<< modified
On Error GoTo 0
If sh Is Nothing Then
Set sh = Worksheets.Add
sh.Name = shName '<<<<< modified
.Rows(1).Copy sh.Range("A1")
iRow = 2
Else
iRow = sh.UsedRange.Rows.Count + 1 '<<<<< modified
End If
.Rows(i).Copy sh.Range("A" & iRow)
Next i
.Activate
End With

End Sub

--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Max]

Thanks for the amended sub, Bob. I tested it over several runs here. Noticed
that the sub misses out TEST_COLUMN's blank cells if these are located right
at the bottom. In-between blank cells are spliced ok into "Blanks". Could
this be rectified?

(Rest of the scenarios work fine)

---

 

[Bob Phillips]

The problem here Max is that it tests column A to find the last row, and so
misses those tail blanks.

Best to use a more generic lastrow function

Option Explicit

Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long
Dim iLastRow As Long
Dim iRow As Long
Dim sh As Worksheet
Dim shName As String

With ActiveSheet

iLastRow = LastRow(ActiveSheet)
For i = 2 To iLastRow
If IsError(.Cells(i, TEST_COLUMN).Value) Then
shName = "Err"
ElseIf .Cells(i, TEST_COLUMN).Value = "" Then
If .Cells(i, TEST_COLUMN).HasFormula Then
shName = "NS"
Else
shName = "Blanks"
End If
Else
shName = .Cells(i, TEST_COLUMN).Value
End If
Set sh = Nothing
On Error Resume Next
Set sh = Worksheets(shName)
On Error GoTo 0
If sh Is Nothing Then
Set sh = Worksheets.Add
sh.Name = shName
.Rows(1).Copy sh.Range("A1")
iRow = 2
Else
iRow = sh.UsedRange.Rows.Count + 1
End If
.Rows(i).Copy sh.Range("A" & iRow)
Next i
.Activate
End With

End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function



--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Max]

Apologies for the delayed reply, Bob.
Yes, your last amendment did it.
Runs superb. Thanks!

---