Extract Whole Row If Q

[Dave Peterson]

Glad you got it working.

I would have guessed that wsnew would have been the activesheet/activewindow.

So the first line in this section wasn't needed:

wsnew.select
activewindow.zoom = 75
activewindow.displaygridlines = false

If it were really needed, then this code has a bug. The workbook that owns
wsnew has to be active to be able to select that worksheet. You should add one
more line:

wsnew.parent.activate
wsnew.select
activewindow.zoom = 75
activewindow.displaygridlines = false

 

[Sean]

Dave, it seems to work with and without wsnew.parent.activate, so I've
placed it in the code anyway

As I'm on it I might as well ask. How could I create a Subtotal on
each of the new sheets? The recorded version is below, however the
ranges I have are variable for each sheet, depending on the lines of
data, although everything starts at A12:Q, so I can't hard code these
in, I could I guess use a Dynamic Range, but how could I create one of
these via code?



Range("A12:Q49").Select
Selection.Subtotal GroupBy:=2, Function:=xlSum,
TotalList:=Array(10), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
Range("A1").Select
End Sub

 

[Dave Peterson]

'....
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("X1:X2"), _
CopyToRange:=wsNew.Range("A12"), _
Unique:=False

wsNew.Range("R:iv").Delete

with wsnew
'no adjustment here!
lastrow = .cells(.rows.count,"A").end(xlup).row
.range("a12:q" & lastrow).subtotal _
GroupBy:=2, Function:=xlSum, TotalList:=Array(10), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True

'maybe you want this, too
.parent.saveas _
filename:=c.parent.parent.path & "\" & c.value & ".xls", _
fileformat:=xlworkbook.normal
.parent.close savechanges:=false
end with
Next c

I've lost track of what the details of the code really are.

If c.value is a valid name to Windows, you could add that last step to save in
the same folder as the original workbook.

c.parent is the worksheet (2007, I think)
c.parent.parent is the workbook that owns that worksheet.

you could also be specific:

.parent.saveas _
filename:="C:\myexistingpathnamehere\" & c.value & ".xls", _
fileformat:=xlworkbook.normal

 

[Sean]

Dave, that Subtotal code is superb and now you have me thinking on the
save routine. What if I was to save each Exported file in the format
"Original File Name - Worksheet Name" i.e. the sheet name that is
given to each Exported file, all saved to a specific file path and if
file exists it replaces whatever is there. Reason for this is that
I'll just replace each file with a new one each month

I'm guessing is something like, but not sure how to obtain the parent
name and add the dash

.parent.saveas _
filename:="C:\myexistingpathnamehere\.parentname " & -
c.value & ".xls", _
fileformat:=xlworkbook.normal
.parent.close savechanges:=false

My working code is below:

Option Explicit
Sub ExtractAMs()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Long
Dim c As Range
Dim LastRow As Long

Application.ScreenUpdating = False

Set ws1 = Sheets("2007")

With ws1
.Range("R:IV").Delete

'rebuild it each time???
Call InsertAMName

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A12:r" & LastRow)

'extract a list of unique managers in column Y
.Range("r12:r" & LastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("Y1"), _
Unique:=True

r = Cells(.Rows.Count, "Y").End(xlUp).Row

For Each c In Range("Y2:Y" & r).Cells
'workbooks.add(1) creates a new workbook with a single
sheet
'workbooks.add(1).worksheets(1) is that sheet
Set wsNew = Workbooks.Add(1).Worksheets(1)
wsNew.Name = c.Value

'build the criteria range in X1:X2
.Range("x1").Value = .Range("y1").Value
.Range("x2").Value = "=" & Chr(34) & "=" & c.Value &
Chr(34)

.Rows("1:11").Copy _
Destination:=wsNew.Range("a1")

rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("X1:X2"), _
CopyToRange:=wsNew.Range("A12"), _
Unique:=False

.Columns("A:Q").Copy
wsNew.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths

wsNew.Parent.Activate
wsNew.Select
ActiveWindow.Zoom = 75
ActiveWindow.DisplayGridlines = False

wsNew.Select
Range("A1").Select

With wsNew
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A12:Q" & LastRow).Subtotal _
GroupBy:=2, Function:=xlSum, TotalList:=Array(10), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End With


wsNew.Range("R:iv").Delete
Next c
End With
ws1.Parent.Activate
ws1.Select
ws1.Columns("R:IV").Delete
End Sub
Sub InsertAMName()
Dim LastRow As Long
Application.ScreenUpdating = False
With Worksheets("2007")
'add a header for column R in Row 12
.Range("R12").Value = "Manager"
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row - 2
.Range("R13:R" & LastRow).Formula _
= "=VLOOKUP(B13,AM_Lookup,2,false)"
End With
End Sub

 

[Dave Peterson]

Dim myFileName as string 'at the top near the other dim's

.....

myfilename = c.parent.parent.fullname 'includes path, too
'remove the .xls
myfilename = left(myfilename, len(myfilename) - 4)
add the worksheet name and .xls
myfilename = myfilename & " - " & c.value & ".xls"

'stop the "overwrite?" prompt
application.displayalerts = false
..parent.saveas filename:=myfilename, fileformat:=xlworkbooknormal
application.displayalerts = true

'close it
..parent.close savechanges:=false

===
Ps. I hate to see unqualified ranges!

 

[Sean]

Dave, that code has done something strange, its created a new file,
named correctly but only for the first manager in the filter yet has
all the original files data (should only have that managers data).
Perhaps its where I placed the code which was after

With wsNew
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A12:Q" & LastRow).Subtotal _
GroupBy:=2, Function:=xlSum, TotalList:=Array(10), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End With

 

[Dave Peterson]

I don't understand the question. Maybe you could rephrase.

And include all the current code.

 

[Sean]

Dave, here it is as it now stands, I've definitely not put something
in correctly on the 'save' routine


Option Explicit
Sub ExtractAMs()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Long
Dim c As Range
Dim LastRow As Long
Dim myFileName As String

Application.ScreenUpdating = False

Set ws1 = Sheets("2007")

With ws1
.Range("R:IV").Delete

'rebuild it each time???
Call InsertAMName

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A12:r" & LastRow)

'extract a list of unique managers in column Y
.Range("r12:r" & LastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("Y1"), _
Unique:=True

r = Cells(.Rows.Count, "Y").End(xlUp).Row

For Each c In Range("Y2:Y" & r).Cells
'workbooks.add(1) creates a new workbook with a single
sheet
'workbooks.add(1).worksheets(1) is that sheet
Set wsNew = Workbooks.Add(1).Worksheets(1)
wsNew.Name = c.Value

'build the criteria range in X1:X2
.Range("x1").Value = .Range("y1").Value
.Range("x2").Value = "=" & Chr(34) & "=" & c.Value &
Chr(34)

.Rows("1:11").Copy _
Destination:=wsNew.Range("a1")

rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("X1:X2"), _
CopyToRange:=wsNew.Range("A12"), _
Unique:=False

.Columns("A:Q").Copy
wsNew.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths

wsNew.Parent.Activate
wsNew.Select
ActiveWindow.Zoom = 75
ActiveWindow.DisplayGridlines = False

wsNew.Select
Range("A1").Select

With wsNew
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A12:Q" & LastRow).Subtotal _
GroupBy:=2, Function:=xlSum, TotalList:=Array(10), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End With


myFileName = c.Parent.Parent.FullName 'includes path, too
'remove the .xls
myFileName = Left(myFileName, Len(myFileName) - 4)
'add the worksheet name and .xls
myFileName = myFileName & " - " & c.Value & ".xls"


'stop the "overwrite?" prompt
Application.DisplayAlerts = False
.Parent.SaveAs Filename:=myFileName,
FileFormat:=xlWorkbookNormal
Application.DisplayAlerts = True


'close it
.Parent.Close savechanges:=False


wsNew.Range("R:iv").Delete
Next c
End With
ws1.Parent.Activate
ws1.Select
ws1.Columns("R:IV").Delete
End Sub
Sub InsertAMName()
Dim LastRow As Long
Application.ScreenUpdating = False
With Worksheets("2007")
'add a header for column R in Row 12
.Range("R12").Value = "Manager"
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row - 2
.Range("R13:R" & LastRow).Formula _
= "=VLOOKUP(B13,AM_Lookup,2,false)"
End With
End Sub

 

[Dave Peterson]

Without looking too closely, this line:

wsNew.Range("R:iv").Delete

is in the wrong location--either delete it or move it before the .saveas line.

But I still don't understand your problem.

 

[Sean]

The save routine is not quite what I was looking for. I'm looking to
have the exported/filtered files saved into the same location as the
parent file, with a file name structure as "Original File name -
Exported Files sheet name". Then close all Exported files, but leave
the Parent file still open

What is happening is that there is only 1 Exported file being created
(but instead of having data relevant to the specific manager it shows
all data with no subtotals), this is then being saved and closed, as
is the parent, but whats left open is the same Exported file, with
subtotals etc although its not named. It doesn't create any of the
other 3 expected filtered files

 

[Dave Peterson]

I see.

Option Explicit
Sub ExtractAMs()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Long
Dim c As Range
Dim LastRow As Long
Dim myFileName As String

Application.ScreenUpdating = False

Set ws1 = Sheets("2007")

With ws1
.Range("R:IV").Delete

'rebuild it each time???
Call InsertAMName

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A12:r" & LastRow)

'extract a list of unique managers in column Y
.Range("r12:r" & LastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("Y1"), _
Unique:=True

r = Cells(.Rows.Count, "Y").End(xlUp).Row

For Each c In Range("Y2:Y" & r).Cells
'workbooks.add(1) creates a new workbook with a single Sheet
'workbooks.add(1).worksheets(1) is that sheet
Set wsNew = Workbooks.Add(1).Worksheets(1)
wsNew.Name = c.Value

'build the criteria range in X1:X2
.Range("x1").Value = .Range("y1").Value
.Range("x2").Value = "=" & Chr(34) & "=" & c.Value & Chr(34)

.Rows("1:11").Copy _
Destination:=wsNew.Range("a1")

rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("X1:X2"), _
CopyToRange:=wsNew.Range("A12"), _
Unique:=False

.Columns("A:Q").Copy

With wsNew
.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
.Parent.Activate
.Select
ActiveWindow.Zoom = 75
ActiveWindow.DisplayGridlines = False
.Range("A1").Select
.Range("R:iv").Delete

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

.Range("A12:Q" & LastRow).Subtotal _
GroupBy:=2, Function:=xlSum, TotalList:=Array(10), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True

myFileName = c.Parent.Parent.FullName
myFileName = Left(myFileName, Len(myFileName) - 4)
myFileName = myFileName & " - " & c.Value & ".xls"

Application.DisplayAlerts = False
.Parent.SaveAs Filename:=myFileName, _
FileFormat:=xlWorkbookNormal
Application.DisplayAlerts = True
.Parent.Close savechanges:=False
End With
Next c
End With

ws1.Parent.Activate
ws1.Select
ws1.Columns("R:IV").Delete

End Sub
Sub InsertAMName()
Dim LastRow As Long
Application.ScreenUpdating = False
With Worksheets("2007")
'add a header for column R in Row 12
.Range("R12").Value = "Manager"
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row - 2
.Range("R13:R" & LastRow).Formula _
= "=VLOOKUP(B13,AM_Lookup,2,false)"
End With
End Sub

=======
This line

..parent.saveas ...
refered to the object in the previous With statement (without a corresponding
End With statement).

In the other code, the object in the previous with statement was WS1
(worksheets("2007")).

I rearranged the code a bit just to clean it up a bit--now .parent.saveas refers
to wsnew.

 

[Sean]

That code works exactly how I want it Dave, thanks

 

[Dave Peterson]

Whew!

Glad it's working.

That code works exactly how I want it Dave, thanks