Macro for Large workbook

[Jules]

Hi, I have a workbook containing approx 80 worksheets, all are exactly a
like. All the sheets names are seven digits (cost centers), these numbers
can be found in the sheet.

I need to delete all the lines not associated with the tab name (which I
have referenced in C3). There are many subtotals in the worksheets; these
consist of staff positions within the cost center.

So, in essence, I have all the cost centers on each tab, but only need the
info for the cost center referenced by the tab.

Is this possible? Can anyone please help me? I'm an intermediate user but
I follow directions fairly well.

Sign me

Despreate in B'more

 

[Per Jessen]

Hi, I have a workbook containing approx 80 worksheets, all are exactly a
like.  All the sheets names are seven digits (cost centers), these numbers
can be found in the sheet.  

I need to delete all the lines not associated with the tab name (which I
have referenced in C3).  There are many subtotals in the worksheets; these
consist of staff positions within the cost center.  

So, in essence, I have all the cost centers on each tab, but only need the
info for the cost center referenced by the tab.  

Is this possible?  Can anyone please help me?  I'm an intermediate user but
I follow directions fairly well.

Sign me

Despreate in B'more

Hi Jules

In wich column can I find the cost center?

Which row is the first to look at ?

Regards,
Per

 

[Per Jessen]

Hi, I have a workbook containing approx 80 worksheets, all are exactly a
like.  All the sheets names are seven digits (cost centers), these numbers
can be found in the sheet.  

I need to delete all the lines not associated with the tab name (which I
have referenced in C3).  There are many subtotals in the worksheets; these
consist of staff positions within the cost center.  

So, in essence, I have all the cost centers on each tab, but only need the
info for the cost center referenced by the tab.  

Is this possible?  Can anyone please help me?  I'm an intermediate user but
I follow directions fairly well.

Sign me

Despreate in B'more

Hi

Try this on a copy of your workbook. Change TargetColumn and FirstRow
to suit.

Sub RemoveLines()
Dim sh As Variant
Dim LastRow As Double
Dim FirstRow As Double
Dim r As Variant
Dim TargetColumn As String

TargetColumn = "A"
FirstRow = 5

For Each sh In ThisWorkbook.Sheets
CostCenter = sh.Name
With sh
LastRow = .Range("A65536").End(xlUp).Row
For r = LastRow To FirstRow Step -1
If .Cells(r, TargetColumn).Value <> CostCenter Then
.Rows(r).Delete
End If
Next
End With
Next
End Sub

Best regards,
Per

 

[Jules]

Thanks Per....the macro is having trouble at the End if line...also, I need
to keep the last few lines in tact on each sheet (rows a1368 - 1386) Also,
the row is A6 and the data in the sheet referencing the cost center is in
column G. I don't know if this helps...

Would it be easier to start with the one template and bust out the sheets by
cost center with a different macro? Right now I've used ASAP utilitly to
break out the sheets by cost center...but if you know a better way...?

Thanks so much for all your help.,

 

[Per Jessen]

Hi Jules

Does the macro comes up with an error or what is the problem at the end if
line?

This macro will look at rows 6-1367 and delete rows where the CostCenter in
column G is not equal to the cost center on the tab.

Sub RemoveLines()
Dim sh As Variant
Dim LastRow As Double
Dim FirstRow As Double
Dim r As Variant
Dim TargetColumn As String

TargetColumn = "G"
FirstRow = 6
LastRow = 1367

For Each sh In ThisWorkbook.Sheets
CostCenter = sh.Name
With sh
For r = LastRow To FirstRow Step -1
If .Cells(r, TargetColumn).Value <> CostCenter Then
.Rows(r).Delete
End If
Next
End With
Next
End Sub

Regards,
Per

 

[Jules]

Hi Per,

I've tried to run this different ways...The workbook has apporx 84 sheets,
all the same...I need to break out each sheet according to the tab name...as
you know.

When I run this (I've tried selecting all sheets and running it as well as
just one sheet), I get the hour glass for about twenty minutes than I end
task and only one sheet has been changed (correctly), the others are not
touched...it doesn't matter how long it runs, you have to end task to get
out...

Just thought I'd update you on this...

Sign me....

Still looking for a fix.

kind regards Per.

 

[Per Jessen]

Hi Jules

I have made a new approach to your problem

The macro creates a new workbook, where the the desired result is copied to.

I have estimated the range to copy, change the CopyRange if it doesn't suit
your needs.

Sub RemoveLines_WithFilter()
Dim ws As Variant
Dim LastRow As Double
Dim FirstRow As Double
Dim r As Variant
Dim CostCenter
Dim TargetColumn As String
Dim NewWb As Workbook
Dim OldWb As Workbook
Dim NewWs As Worksheet
Dim CopyRange As String

Application.ScreenUpdating = False
Set OldWb = ThisWorkbook
Set NewWb = Workbooks.Add

CopyRange = "A11386" ' Change to suit the _
range containing data
TargetColumn = "G"
FirstRow = 6
LastRow = 1367
OldWb.Activate

For Each ws In OldWb.Worksheets
Set NewWs = NewWb.Sheets.Add
Debug.Print ws.Name
NewWs.Name = ws.Name
Next

For Each ws In OldWb.Worksheets
CostCenter = ws.Name
ws.Select
Range(Cells(FirstRow, TargetColumn), _
Cells(LastRow, TargetColumn)).Select
Selection.AutoFilter Field:=1, Criteria1:=CostCenter
Range("A1:M45").Copy NewWb.Sheets(CostCenter).Range("A1")
Selection.AutoFilter
Next

Application.ScreenUpdating = True
End Sub

Best regards,
Per

 

[Per Jessen]

Just a little correction to the code.

Sub RemoveLines_WithFilter()
Dim ws As Variant
Dim LastRow As Double
Dim FirstRow As Double
Dim r As Variant
Dim CostCenter
Dim TargetColumn As String
Dim NewWb As Workbook
Dim OldWb As Workbook
Dim NewWs As Worksheet
Dim CopyRange As String

Application.ScreenUpdating = False
Set OldWb = ThisWorkbook
Set NewWb = Workbooks.Add

CopyRange = "A1:H1386" ' Change to suit the _
range containing data
TargetColumn = "G"
FirstRow = 6
LastRow = 1367
OldWb.Activate

For Each ws In OldWb.Worksheets
Set NewWs = NewWb.Sheets.Add
Debug.Print ws.Name
NewWs.Name = ws.Name
Next

For Each ws In OldWb.Worksheets
CostCenter = ws.Name
ws.Select
Range(Cells(FirstRow, TargetColumn), _
Cells(LastRow, TargetColumn)).Select
Selection.AutoFilter Field:=1, Criteria1:=CostCenter
Range(CopyRange).Copy NewWb.Sheets(CostCenter).Range("A1")
Selection.AutoFilter
Next

Application.ScreenUpdating = True
End Sub

Regards,
Per

 

[Jules]

Thanks Per...I worked great!
--
Jules

Just a little correction to the code.

Sub RemoveLines_WithFilter()
Dim ws As Variant
Dim LastRow As Double
Dim FirstRow As Double
Dim r As Variant
Dim CostCenter
Dim TargetColumn As String
Dim NewWb As Workbook
Dim OldWb As Workbook
Dim NewWs As Worksheet
Dim CopyRange As String

Application.ScreenUpdating = False
Set OldWb = ThisWorkbook
Set NewWb = Workbooks.Add

CopyRange = "A1:H1386" ' Change to suit the _
range containing data
TargetColumn = "G"
FirstRow = 6
LastRow = 1367
OldWb.Activate

For Each ws In OldWb.Worksheets
Set NewWs = NewWb.Sheets.Add
Debug.Print ws.Name
NewWs.Name = ws.Name
Next

For Each ws In OldWb.Worksheets
CostCenter = ws.Name
ws.Select
Range(Cells(FirstRow, TargetColumn), _
Cells(LastRow, TargetColumn)).Select
Selection.AutoFilter Field:=1, Criteria1:=CostCenter
Range(CopyRange).Copy NewWb.Sheets(CostCenter).Range("A1")
Selection.AutoFilter
Next

Application.ScreenUpdating = True
End Sub

Regards,
Per