ExcelBanter - Using a macro to make a list from results

This code takes the selected data and makes a unique list from it...
Sub Create_Unique_List_From_Selected_Range()
'need to edit to verify first rows are not blank

Dim Wsht As Worksheet
Dim CurrentSheet As Worksheet
Dim myr As Range
Dim Sheetname As String
Application.ScreenUpdating = False
Set myr = Selection

'save CurrentSheet
Set CurrentSheet = ActiveSheet

'add a new Sheet for the filtered list
Set Wsht = Sheets.Add

'rename sheet. if sheet already exists, prompt user for new name
Sheetname = "Filtered List"

While Validate_New_Sheet_Name(Sheetname) < True
Sheetname = InputBox("The sheet " & Sheetname & " already exists."
& _
" Please enter a new sheet name", , Sheetname)
Wend

Wsht.Name = Sheetname

'copy the selected range to the new sheet
CurrentSheet.Select

If Selection.Rows.Count = 65536 Then 'user selected entire column.
change selection to be 1st to last used row efficiency
Range(Left(Selection.Address, InStr(1, Selection.Address, ":") -
1) & "$1:$" & StrReverse(Left(StrReverse(Selection.Address), InStr(1,
StrReverse(Selection.Address), "$") - 1)) & "$" &
ActiveCell.SpecialCells(xlLastCell).Row).Select
End If

Selection.Copy

Wsht.Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Cells.Select
Selection.EntireColumn.AutoFit
Range("A1", ActiveCell.SpecialCells(xlLastCell)).Select
'delete leading blank rows before using Advanced Filter - Unique
For Rw = 1 To Selection.Rows.Count
'If entire row is blank
If
Application.WorksheetFunction.CountA(Selection.Row s(Rw).EntireRow) = 0
Then

'Delete row
Selection.Rows(Rw).EntireRow.Delete

'adjust the counter
Rw = Rw - 1

Else 'you've found the first non blank row so exit the loop

Exit For
End If
Next Rw

'insert a col. and combine all the data in each row into 1 cell for
sort
'data needs to be sorted for filter-unique to work
Range("a:a").Insert
Range("A1", ActiveCell.SpecialCells(xlLastCell)).Select
For myRow = 1 To Selection.Rows.Count
For myCol = 1 To Selection.Columns.Count
Cells(myRow, 1).Value = Cells(myRow, myCol) & Cells(myRow,
myCol)
Next
Next

'sort data
'Range("A1", ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending,
Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'delete the sort column
Range("A:A").Delete
Range("1:1").Insert

'add a header row for filter, otherwise 1st 2 rows of data may repeat
after filter
For myCol = 1 To Selection.Columns.Count
Cells(1, myCol) = "Col" & myCol
Next

'filter the data to find only the unique rows. Paste list in row 1 in
the next available column
'find the last used column so that you can determine where to paste
the filtered list
LastColumnNumber = ActiveCell.SpecialCells(xlLastCell).Column + 1
If LastColumnNumber 26 Then
LastColumnLetter = Chr(Int((LastColumnNumber - 1) / 26) + 64) & _
Chr(((LastColumnNumber - 1) Mod 26) + 65)

Else
LastColumnLetter = Chr(LastColumnNumber + 64)
End If

Selection.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
LastColumnLetter & "1"), Unique:=True

'now delete the original data so the user is only left with the unique
filtered list
LastColumnNumber = LastColumnNumber - 1
If LastColumnNumber 26 Then
LastColumnLetter = Chr(Int((LastColumnNumber - 1) / 26) + 64) & _
Chr(((LastColumnNumber - 1) Mod 26) + 65)

Else
LastColumnLetter = Chr(LastColumnNumber + 64)
End If

'delete columns / rows added for filtering
Range("a:" & LastColumnLetter).Delete
Range("1:1").Delete

'autofit new data:
Cells.Select
Selection.EntireColumn.AutoFit

'reset last used cell
X = ActiveSheet.UsedRange.Rows.Count

'select the new list so user can quickly copy / paste
Range("A1", ActiveCell.SpecialCells(xlLastCell)).Select

Application.ScreenUpdating = True

End Sub

Function Validate_New_Sheet_Name(NewSheetName As String) As Boolean

'first check to see if the sheet name is valid
If NewSheetName = "" Then
Validate_New_Sheet_Name = False
Exit Function
End If

'next check to see if already exists in workbook.
For i = 1 To Application.Worksheets.Count

'compare the NewSheetName to the current tab in the
workbook. If it agrees, the tab
' exists. Return false. Otherwise return true.
If StrConv(NewSheetName, vbProperCase) =
StrConv(Sheets(i).Name, vbProperCase) Then
'tab found. return false
Validate_New_Sheet_Name = False
Exit Function
End If

'check the length of the sheet name
If Len(NewSheetName) 31 Then
'new name too long. return false
Validate_New_Sheet_Name = False
Exit Function
End If

Next
'sheet name passed validations.
Validate_New_Sheet_Name = True

End Function

On Jun 2, 7:04 am, deemo85 wrote:
Hi,

I have made a macro that runs another macro and copies the results to a new
column thus creating a list. I want to make the macro run over a large
number of cycles and create a large list without me having to type in the
same command over and over. How can I do this? I have pasted the macro below:

Sub Macro8()
'
' Macro8 Macro
' Macro recorded 2/06/2008 by deemo
'

'
Application.Run "Iterate2"
Range("B1").Select
Selection.Copy
Range("N8").Select
ActiveSheet.Paste
Range("F1").Select
Selection.Copy
Range("O8").Select
ActiveSheet.Paste
Application.Run "Iterate2"
Range("B1").Select
Selection.Copy
Range("N9").Select
ActiveSheet.Paste
Range("F1").Select
Selection.Copy
Range("O9").Select
ActiveSheet.Paste
Application.Run "Iterate2"
Range("B1").Select
Selection.Copy
Range("N10").Select
ActiveSheet.Paste
Range("F1").Select
Selection.Copy
Range("O10").Select
ActiveSheet.Paste
End Sub

Thanks!