Easy VBA need help: Output unique value to new sheet

[mrchonginhk]

Hi,

I need to write a code to output the unique value of current range which contains repeating value and text but no space to a new sheet called "MyNewSheet".

Then I need another set of code, same as above, but if the system found "MyNewSheet" is already there, output it to sheet "MyNewSheet1",
"MyNewSheet2","MyNewSheet3" etc.

Thanks

 

[HalfAce]

OK, this is untested, but just looking at it (through tired eyes ), I think it ought to work.
Instead of just selecting AE21, it will use the first blank cell below the last data in column AE. (Is that what you wanted, considering your question "What if AE21 has value already ?")
Again, it's untested, so if it gives you an error, post back with which line is highlighted on debug.


<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> MrChongTestSub()
<SPAN style="color:#00007F">Dim</SPAN> Ws <SPAN style="color:#00007F">As</SPAN> Worksheet, ShtCnt <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>, NewShtCnt <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>
<SPAN style="color:#00007F">Dim</SPAN> x <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>, c <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>, i <SPAN style="color:#00007F">As</SPAN> Range
ShtCnt = Sheets.Count
NewShtCnt = 0
x = 0
i = Range("AE65536").End(xlUp)(2, 1)

Selection.Offset(-1).Select
c = ActiveCell.Column
ActiveCell.FormulaR1C1 = <SPAN style="color:#00007F">For</SPAN>mat("Output Result", ";;;")
Selection.Resize.CurrentRegion.Select
Selection.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range(i), Unique:=<SPAN style="color:#00007F">True</SPAN>
Range(i).CurrentRegion.Cut
<SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> Ws <SPAN style="color:#00007F">In</SPAN> Worksheets
    <SPAN style="color:#00007F">If</SPAN> Ws.Name = "MyNewSheet" <SPAN style="color:#00007F">Then</SPAN>
    x = 1
    Else: <SPAN style="color:#00007F">If</SPAN> InStr(Ws.Name, "MyNewSheet") <SPAN style="color:#00007F">Then</SPAN> NewShtCnt = NewShtCnt + 1
    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>
<SPAN style="color:#00007F">Next</SPAN>
<SPAN style="color:#00007F">If</SPAN> x = 0 <SPAN style="color:#00007F">Then</SPAN>
    Sheets.Add , After:=Sheets(ShtCnt)
    ActiveSheet.Name = "MyNewSheet"
    ActiveSheet.Paste
    Range("D10").Select
    MsgBox "Done !!!"
<SPAN style="color:#00007F">Exit</SPAN> <SPAN style="color:#00007F">Sub</SPAN>
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>
For <SPAN style="color:#00007F">Each</SPAN> Ws <SPAN style="color:#00007F">In</SPAN> Worksheets
    <SPAN style="color:#00007F">If</SPAN> InStr(Ws.Name, "MyNewSheet") And Ws.Index = ShtCnt <SPAN style="color:#00007F">Then</SPAN>
        Sheets.Add , After:=Sheets(ShtCnt)
        ActiveSheet.Name = "MyNewSheet" & NewShtCnt + 1
        NewShtCnt = NewShtCnt + 1
        ActiveSheet.Paste
        Range("D10").Select
        MsgBox "Done !!!"
   <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>
<SPAN style="color:#00007F">Next</SPAN>

<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

Are we getting any closer to what you want?
Dan

 

[timwangTM]

I just think that we maybe take the great advantage of using Collection object. As you know in one Collection object, every item must be unique. In this case, 1) first we can fill the Collection object with selected cells; 2) then we can export every item (unique) within Collection into targeted sheet.

Like following codes (not yet tested):

Dim myCell As Range, mySelection As Range
Dim myItem As Variant, myCollection As New Collection

Sub MakeCollection()
Set mySelection = Selection
For Each myCell In mySelection
On Error Resume Next
If myCell <> "" Then
myCollection.Add myCell, CStr(myCell)
End If
Next
Debug.Print myCollection.Count
End Sub

Sub ExportCollection()
For Each myItem In myCollection
Debug.Print myItem 'Here I just simply print it out in Immediate window.
Next
End Sub

Have a try.

 

[Yogi Anand]

Hi mrchonginhk:

If I understand you correctly, the following approach using AdvancedFilter may be of interest to you ...

Sub yChong()
    'let us say range of interest in SheetStart is B1:B6
    Sheets("SheetStart").Activate
    Sheets.Add
    'let us say we want to write the unique entries in cell C1 of the AddedSheet
    Sheets("SheetStart").Range("B1:B6").AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Range("B1"), Unique:=True
    Sheets("SheetStart").Activate
End Sub

Let me know if it helps!