T
Tim879
Hi,
I am trying to write a macro that returns a unique list of values
based on the user's selection
(i.e. if the user's selection contained the following starting in cell
A1:
list
apples
apples
pears
pears
d
d
house
house
row
the macro would return
list
apples
pears
d
house
row
Problem is that the code does not work if the user selects blank rows
before the data begins.
Any suggestions on how to resize the selection to exclude the LEADING
blank rows?
My code is posted below. Just highlight a range of cells and run it.
Thanks
Tim
Sub Create_Unique_List()
'need to edit to verify first rows are not blank
'need to validate WS name
Dim wsht As Worksheet
Dim CurrentSheet As Worksheet
Dim myr As Range
Dim Sheetname As String
Set myr = Selection
'check for leading blank rows in selection
If myr.Cells(1, 1).Value = "" Then
MsgBox ("Unique filter will not work if the first row contains a
blank cell." _
& " Please reselect your data and re-run macro")
Exit Sub
End If
Set CurrentSheet = ActiveSheet
Set wsht = Sheets.Add
Sheetname = "Filtered List"
While Validate_New_Sheet_Name(Sheetname) <> True
Sheetname = InputBox("The sheet " & Sheetname & " already exists.
" & _
" Please enter a new sheet name")
Wend
wsht.Name = Sheetname
CurrentSheet.Select
Selection.Copy
wsht.Select
Range("A1").Select
ActiveSheet.Paste
'find the last used column
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
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
Range("a:" & LastColumnLetter).Delete
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
I am trying to write a macro that returns a unique list of values
based on the user's selection
(i.e. if the user's selection contained the following starting in cell
A1:
list
apples
apples
pears
pears
d
d
house
house
row
the macro would return
list
apples
pears
d
house
row
Problem is that the code does not work if the user selects blank rows
before the data begins.
Any suggestions on how to resize the selection to exclude the LEADING
blank rows?
My code is posted below. Just highlight a range of cells and run it.
Thanks
Tim
Sub Create_Unique_List()
'need to edit to verify first rows are not blank
'need to validate WS name
Dim wsht As Worksheet
Dim CurrentSheet As Worksheet
Dim myr As Range
Dim Sheetname As String
Set myr = Selection
'check for leading blank rows in selection
If myr.Cells(1, 1).Value = "" Then
MsgBox ("Unique filter will not work if the first row contains a
blank cell." _
& " Please reselect your data and re-run macro")
Exit Sub
End If
Set CurrentSheet = ActiveSheet
Set wsht = Sheets.Add
Sheetname = "Filtered List"
While Validate_New_Sheet_Name(Sheetname) <> True
Sheetname = InputBox("The sheet " & Sheetname & " already exists.
" & _
" Please enter a new sheet name")
Wend
wsht.Name = Sheetname
CurrentSheet.Select
Selection.Copy
wsht.Select
Range("A1").Select
ActiveSheet.Paste
'find the last used column
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
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
Range("a:" & LastColumnLetter).Delete
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