'''''''''''''''''''''''''''distinct value string or numerical example 1 suppose in sheet1 range c1 u have a value
January February March April May June January February March April May June January February March April January February March April May June output should be as follows February March April May June January example 2(in case of numeric) suppose in sheet1 range c1 u have a value 1 1 2 2 3 3 3 4 5 6 7 8 9 10 11 output should be as follows 1 2 3 4 5 6 7 8 9 10 11 note that--->sheet1 c1 range has a current value and sheet3 a1 has distinct value after macro run ''''''''here is the code Option Explicit ''''''''''FORE MORE HELP VISIT http://groups.google.com/group/excel_vba''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''' Sub MergeDistinct() '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' MergeDistinct '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim R As Range ' Range loop variable. Dim LastCell As Range ' Last cell in input columns. Dim WS As Worksheet ' Worksheet reference. Dim N As Long ' Result of duplicates test. Dim M As Long ' Rows in merged list. Dim StartList1 As Range ' First cell of first list to merge. Dim StartList2 As Range ' First cell of second list to merge. Dim StartOutputList As Range ' First cell of merged list. Dim ColumnToMatch As Variant ' Column in input lists to test for duplicates. Dim ColumnsToCopy As Long ' Number of columns in each input list to copy to output. ' This is the column in the input lists ' that is to be tested for duplicates. ColumnToMatch = "C" ' This is the number of columns from each list to ' be merged that are copied to the result list. ColumnsToCopy = 3 ' The output list begins in this cell. Set StartOutputList = Worksheets("Sheet3").Range("A1") ' The first list to be merged starts here. Set StartList1 = Worksheets("Sheet1").Range("C1") Set WS = StartList1.Worksheet With WS M = 1 ' Get the last used cell in the first list to be merged. Set LastCell = .Cells(.Rows.Count, StartList1.Column).End(xlUp) ' Loop through the range of values For Each R In .Range(StartList1, LastCell) If R.Value <> vbNullString Then N = Application.CountIf(StartOutputList.Resize(M, 1), _ R.EntireRow.Cells(1, ColumnToMatch).Text) ' If N = 0, then the item is not in the merged result ' list, so copy the data over. If N > 0, we've already ' encountered the value, so do nothing. If N = 0 Then StartOutputList(M, 1).Resize(1, ColumnsToCopy).Value = _ R.Resize(1, ColumnsToCopy).Value ' M is the number of rows in the merged list. Increment it. M = M + 1 End If End If Next R End With ' The second list to be merged starts here. Set StartList2 = Worksheets("Sheet2").Range("C1") Set WS = StartList2.Worksheet With WS Set LastCell = .Cells(.Rows.Count, StartList2.Column).End(xlUp) For Each R In .Range(StartList2, LastCell) If R.Value <> vbNullString Then N = Application.CountIf(StartOutputList.Resize(M, 1), _ R.EntireRow.Cells(1, ColumnToMatch).Text) If N = 0 Then StartOutputList(M, 1).Resize(1, ColumnsToCopy).Value = _ R.Resize(1, ColumnsToCopy).Value M = M + 1 End If End If Next R End With End Sub ''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''Enjoy On Wed, Dec 23, 2009 at 3:28 AM, Vinod N <nvino...@gmail.com> wrote: > Hi Excel Gurus, > > The following macros complies a unique list from the Range("c21:c3020") and > populated in Cell J3. However, it does not capture numerical values in the > said range. > > Please help in modifiying the following macro where it can populate numeric > as well as alphanumeric unique list > > > Sub GetUnique_Collection() > > 'Using the Collection object > Dim SourceRng As Range > Dim UniqColl As New Collection > Set SourceRng = Range("c21:c3020") > On Error Resume Next > For Each cell In SourceRng.Cells > UniqColl.Add cell.Value, cell.Value > Next > On Error GoTo 0 > ReDim UniqArray(1 To UniqColl.Count) > For i = 1 To UniqColl.Count > UniqArray(i) = UniqColl(i) > Next > 'Optional sort routine can be inserted here > Range("j3").Resize(UniqColl.Count, 1).Value = > WorksheetFunction.Transpose(UniqArray) > End Sub > > -- > Thanks and Regards > > Vinod N > > -- > > ---------------------------------------------------------------------------------- > Some important links for excel users: > 1. Excel and VBA Tutorials(Video and Text), Free add-ins downloads at > http://www.excelitems.com > 2. Excel tutorials at http://www.excel-macros.blogspot.com > 3. Learn VBA Macros at http://www.vbamacros.blogspot.com > 4. Excel Tips and Tricks at http://exceldailytip.blogspot.com > > > To post to this group, send email to excel-macros@googlegroups.com > If you find any spam message in the group, please send an email to: > Ayush Jain @ jainayus...@gmail.com or > Ashish Jain @ 26may.1...@gmail.com > <><><><><><><><><><><><><><><><><><><><><><> > HELP US GROW !! > > We reach over 6,500 subscribers worldwide and receive many nice notes about > the learning and support from the group. Our goal is to have 10,000 > subscribers by the end of 2009. Let friends and co-workers know they can > subscribe to group at > http://groups.google.com/group/excel-macros/subscribe -- ---------------------------------------------------------------------------------- Some important links for excel users: 1. Excel and VBA Tutorials(Video and Text), Free add-ins downloads at http://www.excelitems.com 2. Excel tutorials at http://www.excel-macros.blogspot.com 3. Learn VBA Macros at http://www.vbamacros.blogspot.com 4. Excel Tips and Tricks at http://exceldailytip.blogspot.com To post to this group, send email to excel-macros@googlegroups.com If you find any spam message in the group, please send an email to: Ayush Jain @ jainayus...@gmail.com or Ashish Jain @ 26may.1...@gmail.com <><><><><><><><><><><><><><><><><><><><><><> HELP US GROW !! We reach over 6,500 subscribers worldwide and receive many nice notes about the learning and support from the group. Our goal is to have 10,000 subscribers by the end of 2009. Let friends and co-workers know they can subscribe to group at http://groups.google.com/group/excel-macros/subscribe
