PDA

View Full Version : Filter, Copy and Paste to New Tab



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

mancubus
08-25-2012, 05:42 PM
wellcome to VBAX.

test with backup file.


Sub CreateSheetsForUniqueList()
'adopted from:
'http://www.vbaexpress.com/forum/showpost.php?p=273941&postcount=6

Dim newWS As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Sheets(1).Copy Before:=Sheets(1)

Do Until Sheets(1).Columns(1).SpecialCells(2).Count = 1
newWS = Sheets(1).Cells(2, 1).Value 'for column A
'newWS = Sheets(1).Cells(2, 2).Value 'for column B
'newWS = Sheets(1).Cells(2, 3).Value 'for column C
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = newWS
With Sheets(1).Cells(1).CurrentRegion
.AutoFilter 1, newWS 'for column A
'.AutoFilter 2, newWS 'for column B
'.AutoFilter 3, newWS 'for column C
.Copy Worksheets(newWS).Cells(1)
.Offset(1).EntireRow.Delete
.AutoFilter
End With
Loop

Sheets(1).Delete

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub