Looping on Criteria
 

Hi all,

I'm still having trouble with this one.

I've a list of names in A14 to around A130. I can make a Unquie List
with the below code around 29 unique items.

I now need to check each cell from A14 down. If A14 to A19 are say item
1 in Array e.g John I need it to

Add a new sheet.
Copy A14:AW19
Paste all then paste Special Values

Then loop through the next name in array and do the same. Any help
appreciated as ever




Code:
--------------------

Sub UniqueList()


Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String

Set wSheetStart = ActiveSheet
wSheetStart.AutoFilterMode = False
Set rRange = Range("A13", Range("A65536").End(xlUp))

On Error Resume Next
Application.DisplayAlerts = False
Worksheets("UniqueList").Delete

Worksheets.Add().Name = "UniqueList"

With Worksheets("UniqueList")
rRange.AdvancedFilter xlFilterCopy, , _
Worksheets("UniqueList").Range("A13"), True


Set rRange = .Range("A14", .Range("A65536").End(xlUp))
End With


arr = rRange
'Loop


End Sub


--------------------



VBA Noob


--
VBA Noob
------------------------------------------------------------------------
VBA Noob's Profile: http://www.excelforum.com/member.php...o&userid=33833
View this thread: http://www.excelforum.com/showthread...hreadid=571493

Looping on Criteria
 

Have you try my example in your other thread ?

--
Regards Ron de Bruin
http://www.rondebruin.nl



"VBA Noob" wrote in message
...

Hi all,

I'm still having trouble with this one.

I've a list of names in A14 to around A130. I can make a Unquie List
with the below code around 29 unique items.

I now need to check each cell from A14 down. If A14 to A19 are say item
1 in Array e.g John I need it to

Add a new sheet.
Copy A14:AW19
Paste all then paste Special Values

Then loop through the next name in array and do the same. Any help
appreciated as ever




Code:
--------------------

Sub UniqueList()


Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String

Set wSheetStart = ActiveSheet
wSheetStart.AutoFilterMode = False
Set rRange = Range("A13", Range("A65536").End(xlUp))

On Error Resume Next
Application.DisplayAlerts = False
Worksheets("UniqueList").Delete

Worksheets.Add().Name = "UniqueList"

With Worksheets("UniqueList")
rRange.AdvancedFilter xlFilterCopy, , _
Worksheets("UniqueList").Range("A13"), True


Set rRange = .Range("A14", .Range("A65536").End(xlUp))
End With


arr = rRange
'Loop


End Sub


--------------------



VBA Noob


--
VBA Noob
------------------------------------------------------------------------
VBA Noob's Profile: http://www.excelforum.com/member.php...o&userid=33833
View this thread: http://www.excelforum.com/showthread...hreadid=571493

Looping on Criteria
 

Look at Ron de Bruin's approach:

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

--
Regards,
Tom Ogilvy

"VBA Noob" wrote:


Hi all,

I'm still having trouble with this one.

I've a list of names in A14 to around A130. I can make a Unquie List
with the below code around 29 unique items.

I now need to check each cell from A14 down. If A14 to A19 are say item
1 in Array e.g John I need it to

Add a new sheet.
Copy A14:AW19
Paste all then paste Special Values

Then loop through the next name in array and do the same. Any help
appreciated as ever




Code:
--------------------

Sub UniqueList()


Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String

Set wSheetStart = ActiveSheet
wSheetStart.AutoFilterMode = False
Set rRange = Range("A13", Range("A65536").End(xlUp))

On Error Resume Next
Application.DisplayAlerts = False
Worksheets("UniqueList").Delete

Worksheets.Add().Name = "UniqueList"

With Worksheets("UniqueList")
rRange.AdvancedFilter xlFilterCopy, , _
Worksheets("UniqueList").Range("A13"), True


Set rRange = .Range("A14", .Range("A65536").End(xlUp))
End With


arr = rRange
'Loop


End Sub


--------------------



VBA Noob


--
VBA Noob
------------------------------------------------------------------------
VBA Noob's Profile: http://www.excelforum.com/member.php...o&userid=33833
View this thread: http://www.excelforum.com/showthread...hreadid=571493

Looping on Criteria
 

Hi Ron,

I was having trouble with it hence the repost with a different angle.

Change the following

Set ws1 = Sheets("Control")
Set rng = ws1.Range("A13").CurrentRegion
CopyToRange:=WSNew.Range("A2"), _
Unique:=False


It added the sheets correctly but

It's entering the headers again in Template from Row 2. So Row 1 and
has T to AW headers
It's pasting values into T2 to AW2 down instead of formulas

Not sure why. Any thoughts



VBA Noo

--
VBA Noo
-----------------------------------------------------------------------
VBA Noob's Profile: http://www.excelforum.com/member.php...fo&userid=3383
View this thread: http://www.excelforum.com/showthread.php?threadid=57149

Looping on Criteria
 

Hi Ron,


I think I've adpated your code now. Here's my adapted code which seems
to work for me.

I ended up pasting the data below the formula line then let your code
drag formulas down. Next I cut the headers and pasted them over the
original formula line.

Thanks for your help on this one. I would still would be trying to work
it out this time next year only for you.


Code:
--------------------

Sub Copy_With_AdvancedFilter_To_Worksheets()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim lastrow As Long

Set ws1 = Sheets("Control")
Set rng = ws1.Range("A13").CurrentRegion

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With ws1
rng.Columns(1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True

Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
.Range("IU1").Value = .Range("IV1").Value

For Each cell In .Range("IV2:IV" & Lrow)
.Range("IU2").Value = cell.Value
Sheets("template").Copy after:=ws1
Set WSNew = ActiveSheet
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
On Error GoTo 0
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=WSNew.Range("A6"), _
Unique:=False

With WSNew
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("O5:AW5").AutoFill Destination:=.Range("O5:AW" & lastrow) _
, Type:=xlFillDefault
.Range("O1:AW4").Cut
.Range("O3").Select
ActiveSheet.Paste
.Columns("T:AH").EntireColumn.Hidden = True
End With

Next
.Columns("IU:IV").Clear
End With

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub

--------------------


VBA Noob


--
VBA Noob
------------------------------------------------------------------------
VBA Noob's Profile: http://www.excelforum.com/member.php...o&userid=33833
View this thread: http://www.excelforum.com/showthread...hreadid=571493

Looping on Criteria
 

Another way is to add a empty row between your header rows
(set the height to zero)

Then you can have a current region with one header row

--
Regards Ron de Bruin
http://www.rondebruin.nl



"VBA Noob" wrote in message
...

Hi Ron,


I think I've adpated your code now. Here's my adapted code which seems
to work for me.

I ended up pasting the data below the formula line then let your code
drag formulas down. Next I cut the headers and pasted them over the
original formula line.

Thanks for your help on this one. I would still would be trying to work
it out this time next year only for you.


Code:
--------------------

Sub Copy_With_AdvancedFilter_To_Worksheets()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim lastrow As Long

Set ws1 = Sheets("Control")
Set rng = ws1.Range("A13").CurrentRegion

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With ws1
rng.Columns(1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True

Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
.Range("IU1").Value = .Range("IV1").Value

For Each cell In .Range("IV2:IV" & Lrow)
.Range("IU2").Value = cell.Value
Sheets("template").Copy after:=ws1
Set WSNew = ActiveSheet
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
On Error GoTo 0
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=WSNew.Range("A6"), _
Unique:=False

With WSNew
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("O5:AW5").AutoFill Destination:=.Range("O5:AW" & lastrow) _
, Type:=xlFillDefault
.Range("O1:AW4").Cut
.Range("O3").Select
ActiveSheet.Paste
.Columns("T:AH").EntireColumn.Hidden = True
End With

Next
.Columns("IU:IV").Clear
End With

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub

--------------------


VBA Noob


--
VBA Noob
------------------------------------------------------------------------
VBA Noob's Profile: http://www.excelforum.com/member.php...o&userid=33833
View this thread: http://www.excelforum.com/showthread...hreadid=571493

Looping on Criteria
 

Thanks Ron,

Will give it a go.

Once again thanks for all your help.

My next step is to e-mail the sheets. Will be checking out your site
for that too.

VBA Noob.


--
VBA Noob
------------------------------------------------------------------------
VBA Noob's Profile: http://www.excelforum.com/member.php...o&userid=33833
View this thread: http://www.excelforum.com/showthread...hreadid=571493