canuck1971
08-23-2012, 06:55 PM
Hello Everyone
I know this question has been asked a million times. I have following type of data:
Employee ID Job Title Dept Division Cost Centre Description
I am trying to:
1. Filter by Cost Centre
2. Copy and Paste Data to new tab
3. Name that tab the number of Cost Centre
I found this code, which does what I was for Employee ID (Column A), but am not sure how to modify code to get it to work with other columns.
Any help would be appreciated.
Sub Costcentre()
Application.ScreenUpdating = False
Dim cell, cell2 As Range
Dim lr, lr2, r As Long
Dim str As String
ActiveWorkbook.Sheets(1).Activate
lr = Range("A" & Rows.Count).End(xlUp).Row
For Each cell In Range("A1:A" & lr)
str = cell.Text
r = 1
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = str
ActiveWorkbook.Sheets(2).Activate
lr2 = Range("A" & Rows.Count).End(xlUp).Row
For Each cell2 In Range("A1:A" & lr2)
If cell2.Text = str Then
cell2.EntireRow.Copy Destination:=Sheets(str).Range("A" & r)
r = r + 1
End If
Next cell2
Next cell
Application.ScreenUpdating = True
End Sub
I know this question has been asked a million times. I have following type of data:
Employee ID Job Title Dept Division Cost Centre Description
I am trying to:
1. Filter by Cost Centre
2. Copy and Paste Data to new tab
3. Name that tab the number of Cost Centre
I found this code, which does what I was for Employee ID (Column A), but am not sure how to modify code to get it to work with other columns.
Any help would be appreciated.
Sub Costcentre()
Application.ScreenUpdating = False
Dim cell, cell2 As Range
Dim lr, lr2, r As Long
Dim str As String
ActiveWorkbook.Sheets(1).Activate
lr = Range("A" & Rows.Count).End(xlUp).Row
For Each cell In Range("A1:A" & lr)
str = cell.Text
r = 1
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = str
ActiveWorkbook.Sheets(2).Activate
lr2 = Range("A" & Rows.Count).End(xlUp).Row
For Each cell2 In Range("A1:A" & lr2)
If cell2.Text = str Then
cell2.EntireRow.Copy Destination:=Sheets(str).Range("A" & r)
r = r + 1
End If
Next cell2
Next cell
Application.ScreenUpdating = True
End Sub