Solved: Mega help required to remove 1000 block of code

[khalid79m]

If Range("IV2") <> "" Then
Windows("Master.xls").Activate
Sheets("Data").Select
Cells.Select
Selection.AutoFilter Field:=33, Criteria1:=Range("IV2").Value
Range("A1").CurrentRegion.Select
Selection.Copy
Workbooks.Open Filename:= _
"P:\CET - a\a\bc\" & Range("IV2").Value
Sheets("Data").Select
Range("A1").Select
ActiveSheet.Paste
Run "FAutofit"
ActiveWorkbook.Save
ActiveWorkbook.Close
Windows("Master.xls").Activate
Run "FRTemp"
End If
:banghead: :banghead: :banghead: :banghead: :banghead: :doh:
I need help in reducing this code so it goes through cell IV2 then IV3 and then IV4 and so on and to skip over blanks

Currently I have 1000 block of code ( I am taking over from someone and they have done this same code over and over again and just simply changed the cell value ) as I am required to do some amendment to the code I cannot sit and go through each bit and amend it. so please if there is a vba guru out there please help me condesne this code

[Charlize]

1. make a list of unique items in column iv
2. for each item in that list do autofilter and copy visible cells
to filename ending with value of item in list (each item is a criteria)
3. do the formatting that you want (autofilt ?)
4. save and go on to next unique item

Charlize

[mdmackillop]

Mega help required to remove 1000 block of code

Surely this is Kilo help? :devil2:

[khalid79m]

Sorry i dont understand , can anyone help ?

[Charlize]

for no 1. Sub Create_list_for_filtering()
Dim AllCells As Range, cell As Range
Dim NoDupes As New Collection
Dim i As Integer, j As Integer
Dim Swap1, Swap2, Item
Dim Lrow As Long
Dim itemslist() As String
' Search last filled row
Lrow = Range("IV" & Rows.Count).End(xlUp).Row
' The items are in IV2:IVxxx
Set AllCells = Range("IV2:IV" & Lrow)
' The next statement ignores the error caused
' by attempting to add a duplicate key to the collection.
' The duplicate is not added - which is just what we want!
On Error Resume Next
For Each cell In AllCells
NoDupes.Add cell.Value, CStr(cell.Value)
' Note: the 2nd argument (key) for the Add method must be a string
Next cell
' Resume normal error handling
On Error GoTo 0

' Sort the collection (optional)
For i = 1 To NoDupes.Count - 1
For j = i + 1 To NoDupes.Count
If NoDupes(i) > NoDupes(j) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i

i = 1
' Create array that holds unique items
' Not tested so there could be some flaws in it.
For Each Item In NoDupes
ReDim Preserve itemslist(i)
'array begins counting on 0
itemslist(i - 1).Value = Item.Value
i = i + 1
Next Item
End SubCharlize

[Norie]

If this code is doing what I think it's doing, splitting data out into seperate, existing workbooks based on criteria in column AG, then it could probably all be done, in code, using advanced filter.

[Charlize]

i = 1
' Create array that holds unique items
' Not tested so there could be some flaws in it.
For Each Item In NoDupes
ReDim Preserve itemslist(i)
'array begins counting on 0
itemslist(i - 1).Value = Item.Value
i = i + 1
Next Item
' Because there is one item to many in array
i = i - 1
'For no 2
'This is for the autofilter for each item in itemslist
'and copy to new sheet --- not tested so try it first on bogus data
Dim vloop as long
Dim ws as worksheet
Cells.Select
'Since i has the number of unique items
For vloop = 0 to i-1
'Before loop all cells are selected. Now apply filter with first item in array - position 0
Selection.AutoFilter Field:=33, Criteria1:=itemslist(vloop)
Set ws = worksheets.add
ws.name = itemslist(loop)
Cells.SpecialCells(xlCellTypeVisible).Copy ws
Next vloop