Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Macro for Looping for Criteria Checking | Excel Discussion (Misc queries) | |||
Looping filter criteria | Excel Programming | |||
Problem with basic looping and criteria | Excel Programming | |||
multiple looping criteria | Excel Programming | |||
have input box. Need criteria entered to refer to cond. format criteria | Excel Programming |