Loop through expanding range

[Chad]

Hi All

I have a problem perhaps someone can help with. I have searched for
quite some time and can not find anything.

There is a list of accounts which I want to send through to a template
one at a time. The format looks like this.

Header
Apple
Apple
Apple
Pear
Pear
Orange
Orange

I want to be able to isolate and copy one group at a time send it to
the template then move onto the next group. The list will change
constantly and I have no way to know if there will be one or many more
Apples, oranges etc on the trott.

Thanks

Chad

 

[Barb Reinhardt]

I'm not exactly certain what you want to do. I'm assuming you want to be
able to determine how large the range is for the list of fruits

Sub Test()

Dim myRange As Range
Dim r As Range
Dim aWS As Worksheet

Set aWS = ActiveSheet
Set myRange = aWS.Range("A2") '<~~~replace with the address of the header.
Set myRange = myRange.Offset(1, 0)
lrow = aWS.Cells(aWS.Rows.Count, myRange.Column).End(xlUp).Row

Set myRange = myRange.Resize(lrow - myRange.Row + 1, 1)

'To loop through the range I use this
For Each r In myRange
Debug.Print r.Address, r.Value
Next r

End Sub

 

[Chad]

Hi

Thanks for the response.

Let me try to clarify. Sheet1 is a sheet which has related data on
it.

Col A

Apple
Apple
Apple

I want to copy all the Apples to sheet2. Stuff happens on sheet 2.

Then on sheet1 move onto the pears, copy them to sheet 2, do stuff,
and so on untill all the data has been copied onto sheet2.

This is not so simple as the criteria is always changing and so too is
the range to copy in the original example it was A2:A5 then A6:A7.

I hope I have explained this more clearly.

Thanks in advance

Chad

 

[Don Guillett]

This makes a unique list from col a in col f
Loops thru the unique list to copy items from col a to sheet 9 col a
clears col f list
Modify to suit

Sub makeuniquelist()
Application.ScreenUpdating = False
mc = "a"
lr = Cells(rows.Count, mc).End(xlUp).Row
With Range("A1:A" & lr)
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
.Copy Range("F1")
Application.CutCopyMode = False
ActiveSheet.ShowAllData
End With
flr = Cells(rows.Count, "f").End(xlUp).Row
For Each c In Range("f2:f" & flr)
With Sheets("sheet9")
dlr = .Cells(rows.Count, "a").End(xlUp).Row + 1
Range("A1:a" & lr).AutoFilter Field:=1, Criteria1:=c
'MsgBox c
Range("A2:a" & lr).Copy .Cells(dlr, "a")
Range("A1:a" & lr).AutoFilter
End With
Next c
Range("f1:f" & flr).ClearContents
Application.ScreenUpdating = True
End Sub

 

[Chad]

That is great Don - works really nicely.

Thanks very much for your help.

Chad

 

[Don Guillett]

Glad to help