Extract Whole Row If Q

[Sean]

I'm hoping someone can assist me in creating a report. I have a master
sheet of sales information relating to a number of locations, a
manager looks after a certain number of each of the locations. I wish
to extract on a new File (for each Manager) the information that
relates to them, using the same formats that exists on the master
file. This would be created each month. I would have a table setup
that equates London; Paris; New York with "ManagerA"; Berlin; Boston;
Manchester; Leeds with "ManagerB" etc etc

My info starts on Row 10 on a sheet called master, and can be variable
in lenghth each month. The distinguishing feature on each row that
identifies an area is specified in column B. So if Column B on row 10
said "London" this would be extracted (the extire row, values, formats
etc) to a new file that would self name as whatever the master file
was called+ManagerA. If Column B on row 11 said "Paris" this would be
extracted (the extire row, values, formats etc) to a new file that
would self name as whatever the master file was called+ManagerA. If
Column B on row 12 said "Boston" this would be extracted (the extire
row, values, formats etc) to a new file that would self name as
whatever the master file was called+ManagerB etc etc. This would
continue until the first empty cell in Column A lower than row 10


Thanks for any pointers

 

[Sean]

The code below, extract from Debra Dalgleish's Contextures site kinda
does what I want, except for a couple of things,

(1) it extracts to a new sheet, whereas I'm looking 'ideallly' to a
new file
(2) it has listed the manager per row, weheras I associate a number of
locations to set managers and don't have this listed on each row


Option Explicit

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")

'extract a list of Sales Reps
ws1.Columns("C:C").Copy _
Destination:=Range("L1")
ws1.Columns("L:L").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("J1"), Unique:=True
r = Cells(Rows.Count, "J").End(xlUp).Row

'set up Criteria Area
Range("L1").Value = Range("C1").Value

For Each c In Range("J2:J" & r)
'add the rep name to the criteria area
ws1.Range("L2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("J:L").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

 

[Dave Peterson]

#1. Is there one new file when you're done--with lots of worksheets? Or lots
of workbooks with just one worksheet each when you're done?

#2. I think if you're going to use this advancedfilter and autofilter
technique, you'll have to have the info on each row. You can do it yourself--or
maybe add code to add that info, do the work and remove the column.

 

[Sean]

Hi Dave

# 1 Lots of workbooks with 1 sheet (actually only 4 workbooks in
total)

# 2 On entering the 'Manager name' per row, I guess one could insert a
new column (or use the first free column on the extreme right of my
data) via code. How would I right something like Insert ManagerA in
Column Z if value is ColumnB is any one of "London"; "Paris"; "New
York", insert ManagerB if one of "Berlin"; "Boston"; "Manchester";
"Leeds" etc etc, keeping checking/inserting in ColZ until the first
blank cell in ColB row.... Then use Debra's code taking a/c # 1 above

I don't think I've explained it too well, but hope you get the
flavour. Basically I've a whole load of data, that I want to share,
except only those rows that relate to each regional manager

Thanks

 

[Sean]

I've used an example from Ron De Bruin's site, which gives me a lot,
see below

http://www.rondebruin.nl/copy5.htm#AutoFilter

I've tried to add 9 crieria to extract the locations I want with a
line

rng.AutoFilter Field:=1, Criteria1:="=Loc1", Operator:=xlOr,
Criteria2:="=Loc2", Operator:=xlOr, Criteria3:="=Loc3",
Operator:=xlOr, Criteria4:="=Loc4", Operator:=xlOr,
Criteria5:="=Loc5", Operator:=xlOr, Criteria6:="=Loc6",
Operator:=xlOr, Criteria7:="=Loc7", Operator:=xlOr,
Criteria8:="=Loc8", Operator:=xlOr, Criteria9:="=Loc9"

But it hits debug with error "Named arguement not found" at Criteria3
- have I inserted too many criteria?

 

[Roger Govier]

Hi Sean

One easy way might be to use a formula in your source worksheet in column Z
=IF(ISNUMBER(SEARCH(B1,managerA)),"MangerA",IF(ISNUMBER(SEARCH(B1,ManagerB)),"ManagerB",""))

where you have set up names for ManagerA, ManagerB etc. using
Insert>Name>Define>Name ManagerA Refers to "London", "Paris", "New York"

Then having created the Manager in column Z, use that as your criteria in
the Advanced Filter using Debra's code.

When it is Finished, you will have sheets (in the same Workbook) with the
various splits.
As it is only 4 files you want, then it is easy enough to Right click on the
relevant tab>Move or Copy>click Copy>choose New Workbook as Destination>Save
new Workbook as required.

 

[Dave Peterson]

Just like when you use data|filter|autofilter, you get up to 2 criteria.

 

[Dave Peterson]

#1.

=if(or(b2={"London","Paris","New York"}),"managerA","unknown")

I think I'd create a new sheet (hide it later) with the towns in column A and
the manager's name in column B.

Then I could use:
=if(isna(vlookup(b2,sheet2!a:b,2,false)),"Unknown",vlookup(b2,sheet2!a:b,2,0))

I think it would make updating a bit easier when the managers change.

#2.

Try replacing this portion:

If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If

with
'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
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If

 

[Sean]

Dave, I've got a little routine (see very bottom of post) which places
the Managers name in ColR, but I'm a little lost as to what I proceed
next with i.e. the filtering and how I can get this to appear on a new
file for each.

My data goes from A12:R.. I also have some text above Row12 which I
would like to have on each Managers file too

I've tried below, but I get a "End if without Block if" not sure why
on the last End if.

I've ignored your comment on #2 for the moment just want to get the
basic's of the filter working

Option Explicit


Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("2007")
Set rng = Range("Database")


'extract a list of Sales Reps
ws1.Columns("R:R").Copy _
Destination:=Range("X12")
ws1.Columns("X:X").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("Y12"), Unique:=True
r = Cells(Rows.Count, "Y").End(xlUp).Row


'set up Criteria Area
Range("X1").Value = Range("R1").Value


For Each c In Range("Y12:Y" & r)

'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
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("2007").Range("X12:X13"), _
CopyToRange:=wsNew.Range("A12"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("X:Y").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function




Routine is:

Sub InsertAMName()

Application.ScreenUpdating = False

With Application
.Calculation = xlManual
.MaxChange = 0.001
End With

Sheets("2007").Select

Range("R13").Select
ActiveCell.Formula = "=VLOOKUP(B13,AM_Lookup,2)"

Range("R13").Copy
x = 13
Do Until Cells(x, 1).Value = ""
Cells(x, 18).PasteSpecial xlPasteFormulas
x = x + 1
Loop

With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With

Range("A1").Select

ActiveWorkbook.PrecisionAsDisplayed = False
Application.ScreenUpdating = True

End Sub

 

[Dave Peterson]

How about:

Option Explicit
Sub ExtractReps()

Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Long
Dim c As Range
Dim LastRow As Long

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

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
.Range("R13:R" & LastRow).Formula _
= "=VLOOKUP(B13,AM_Lookup,2,false)"
End With

Application.ScreenUpdating = True

End Sub

 

[Sean]

David the Filter criteria range (In X, Y) is showing some odd things,
and I think its the cos of a debug error.

It looks like

Manager Manager
=ManagerE ManagerA
ManagerB
ManagerC
ManagerD
ManagerE
#N/A

The #N/a appears in Y7 as above

It hits a Type mismatch debug on line "wsNew.Name = c.Value"

Q - How can I get the entire format of the Sheet 2007 to be replicated
on all the filtered sheets? (Column widths)

 

[Dave Peterson]

The easy one...

If you're using xl2k or higher, you can record a macro when you select the
columns (A:R) of 2007 and then do a Paste Special|Column Widths.

And if you're getting an error in column Y, then look at your formula in column
R. You have at least on row that doesn't have a match on in your first column
of the AM_Lookup range. So fix your table for the manager that's causing the
error.

ps.

The funny =ManagerE is a way to make sure that you get what you want on that new
worksheet.

If you used:
Manager
ManagerA
ManagerAB
ManagerABC

Then a criteria range of:
Manager (in Y1)
Manager (in Y2)
would return all those managers.

Manager (in Y1)
=Manager (in Y2)
will give just that unique manager.

 

[Sean]

Ah, I see. Below the very last detail row I have #n/a (on row 2861).
However the piece of code that enters the lookup formula is

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("R13:R" & LastRow).Formula _
= "=VLOOKUP(B13,AM_Lookup,2,false)"

However in the above what does the "Last Row" actually mean?. The last
detail row is 2860, row 2861 is a blank row and row 2862 has a line
top and bottom. I'm assuming the code above interprets 2862 as the
last, but how can I tweak it that it knows 2860 is? My previous code
did that, but I guess it was inefficent in how it operated, thus you
suggested the above.

I am doing this Report each month and the format is always the same,
although the number of detail lines varies. By this I mean there will
always be a blank line followed by a line with top and bottom line
formatted (there are some totals on some columns for this line)

Thanks

 

[Dave Peterson]

Last row was based on the data in column A.

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

If lastrow = 2861, then you have data in A2861 (a misplaced space
character???). Formatting won't affect this. You really have something in
A2861.

You can either clear the cell (I would!) or adjust the line:

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

 

[Dave Peterson]

ps. remember that there are two occurences of that line--one in each
subroutine.

 

[Sean]

Thanks Dave

I did a COUNT and LEN in A2861 but it returned 0, so not sure, I
modified as per your suggestion -

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

But that still left a #n/a in R2861, so I changed it to -

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row - 2 and it seems to
have worked

There was data in Row 2862 but none in Row 2861, in that instance
would you have expected LastRow = .Cells(.Rows.Count,
"A").End(xlUp).Row to work?

Anyway above is working.

On the formatting, recording the macro etc is fine, but how do I
select the relevant Sheets/File name when I can't reference a specific
File name as it could be 'anything' once the code creates the new
workbook. Below hard codes a copy formats to Sheet7, but next time I
run the code a new Sheet4 might be created?

Columns("A:R").Select
Selection.Copy
Windows("Sheet7").Activate
Columns("A:R").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select

 

[Dave Peterson]

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

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

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

could become

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

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

.Columns("A:R").copy
wsnew.range("A1").pastespecial paste:=xlPasteColumnWidths

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

(Untested and uncompiled.)

========
That last line deletes column R from the new worksheet in the new workbook. You
may want to change that.

And I didn't understand the layout of your data. If you have that extra row 2
rows down, then subtracting 2 is what you want to do.

ps. if you're using xl2k, then change xlpastecolumnwidths to 8. It's a bug
that was fixed in xl2002.

 

[Sean]

I'm on xl2003 Dave.Code works great. Deleting ColR is fine, don't need
that on the Exported Files

I've tried to plagiarise your code to set the Zoom and Gridlines,
like-

wsNew.Range("A1").ActiveWindow.Zoom = 75
wsNew.Range("A1").ActiveWindow.DisplayGridlines = False

But guess I'm not that clever. I've tweaked by deleting the
"activewindow" text, but didn't work and I'm only guessing

My layout, essentially has the Data listed from Row 13 (header info on
Row 12), then below the last detailed line (row 2860 in this
instance), I have a blank row (row2861), then just below that is a
Total line (row 2862)

 

[Dave Peterson]

zoom and displaygridlines work on windows.

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

There's not many things you have to select to work on, but I think these two are
a pair of them.

 

[Sean]

Dave, many thanks for your interest in helping me out, which you have
done many times on this NG. Your code works a treat and will save me a
lot of time. I have ideas in terms of 'glossing up' what it now
achieves but this particular thread is accomplished

Thanks again

Sean