Macro to automate task...

  • Thread starter Thread starter Guest
  • Start date Start date
G

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
 
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)
 
Hello Bob

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

Much appreciated
AC
 
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

---
 
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)
 
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)

---
 
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)
 
Apologies for the delayed reply, Bob.
Yes, your last amendment did it.
Runs superb. Thanks!

---
 
Back
Top