Looping on Criteria

[VBA Noob]

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

Please Login or Register  to view this content.

VBA Noob

[Ron de Bruin]

Have you try my example in your other thread ?

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



"VBA Noob" <[email protected]> wrote in message
news:[email protected]...
>
> 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
>

[Tom Ogilvy]

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
>
>

[VBA Noob]

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 2 has T to AW headers
It's pasting values into T2 to AW2 down instead of formulas

Not sure why. Any thoughts



VBA Noob

[Ron de Bruin]

My example is working correct with one header row and a currentregion that stop in column R

Send me your test workbook private and I look at it

For others this is the code I posted in the other thread
******************************************

Insert a new sheet in your workbook with In T1:W1 the headers
In T2:W2 your formulas and name the sheet "template

Now try this one that autofill the formulas in row 2 to the last data in column A


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("Sheet1") '<<< Change
'Tip : Use a Dynamic range name, http://www.contextures.com/xlNames01.html#Dynamic
'or a fixed range like Range("A1:H1200")
Set rng = ws1.Range("A1").CurrentRegion '<<< Change

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

With ws1
rng.Columns(1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
'This example filter on the first column in the range (change this if needed)
'You see that the last two columns of the worksheet are used to make a Unique list
'and add the CriteriaRange.(you can't use this macro if you use the columns)

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("A1"), _
Unique:=False

'WSNew.Columns.AutoFit

With WSNew
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("T2:W2").AutoFill Destination:=.Range("T2:W" & lastrow) _
, Type:=xlFillDefault
End With

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

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






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



"VBA Noob" <[email protected]> wrote in message
news:[email protected]...
>
> 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 2
> has T to AW headers
> It's pasting values into T2 to AW2 down instead of formulas
>
> Not sure why. Any thoughts
>
>
>
> 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
>

[VBA Noob]

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.

Please Login or Register  to view this content.

VBA Noob

[Ron de Bruin]

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" <[email protected]> wrote in message
news:[email protected]...
>
> 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
>

[VBA Noob]

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.