Announcement

Collapse
No announcement yet.

Need your help to sort dic.key value

Collapse
This topic is closed.
X
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Need your help to sort dic.key value



    Hi Team,


    Set dic = CreateObject("scripting.dictionary")

    For Each c In rng

    dic(c.Value) = c.Value

    Next


    """" need to sort each dic value in alphabetically then do below process###


    Range("E2").Resize(dic.count) = Application.Transpose(dic.Keys)



    Thanks so much

  • #2
    Should be not use dictionary
    Code:
    sub test()
    dim r as range
    with CreateObject("System.Collections.Arraylist")
    for each r in columns(1).specialcells(2).cells
      .add cstr(r.value)
    next r
    .sort
    [b1].resize(.count)  = application.Transpose(.toarray)
    end with
    end sub
    Last edited by graha_karya; January 15th, 2019, 14:24.

    Comment


    • #3
      Hi Sir,

      while run the above macro showing below error .. can you please help what is the reason..


      Run Time Error '429'

      ActiveX Component can't create object.


      Comment


      • #4
        Try
        Code:
        Sub axxx()
        dim Al as object, a,v,i&,t$
        Set Al = CreateObject("System.collections.Arraylist")
        a = array("z","x","s","c","d","a","b","e")
        for i = 0 to ubound(a)
           t = Cstr(a(i)) : Al.Add t
        next i
        AL.sort
        msgbox join(Al.toarray,vblf)
        [a1].resize(Al.count) = application.Transpose(Al.Toarray)
        end sub


        Comment


        • #5
          Originally posted by graha_karya View Post
          Should be not use dictionary
          Code:
          sub test()
          dim r as range
          with CreateObject("System.Collections.Arraylist")
          for each r in columns(1).specialcells(2).cells
          .add cstr(r.value)
          next r
          .sort
          [b1].resize(.count) = application.Transpose(.toarray)
          end with
          end sub



          ### with CreateObject("System.Collections.ArrayList") ## because of space between collections. Arraylist

          it s working fine sir.. but I want unique value only.. as I have duplicates values

          Comment


          • #6
            This is the working which I have done with your help sir.. m just stuck over sorting of dic.key now
            Sub Vmn()
            Dim col1, col2, i As Integer
            Dim y()
            Dim rng, c, myrange1, myrange2, sng, ar, kng, mng As Range
            Dim count As Long
            Dim dic As Object
            Dim book, mbook As Workbook
            Dim fn, pt, gn, d As String
            Application.ScreenUpdating = False
            Set mbook = ThisWorkbook
            pt = ThisWorkbook.Path & Application.PathSeparator
            fn = Dir(pt & "*.xls", vbNormal)
            Do Until fn = ""
            If fn <> ThisWorkbook.Name Then
            Set book = Workbooks.Open(Filename:=pt & fn)
            col1 = WorksheetFunction.Match("*Data1*", ActiveSheet.Range("1:1"), 0)
            col2 = WorksheetFunction.Match("*Data2*", ActiveSheet.Range("1:1"), 0)
            lr = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            Set rng = ActiveSheet.Range(Cells(2, col1), Cells(lr, col2))
            Set dic = CreateObject("scripting.dictionary")
            For Each c In rng
            dic(c.Value) = c.Value
            Next
            Set myrange1 = ActiveSheet.Range(Cells(2, col1), Cells(lr, col1)).SpecialCells(xlCellTypeVisible)
            Set myrange2 = ActiveSheet.Range(Cells(2, col2), Cells(lr, col2)).SpecialCells(xlCellTypeVisible)
            If book.Name Like "*1st*" Then
            d = "B19"
            ElseIf book.Name Like "*2nd*" Then
            d = "B32"
            ElseIf book.Name Like "*3rd*" Then
            d = "B41"
            ElseIf book.Name Like "*4th*" Then
            d = "B46"
            Else
            End If
            mbook.Sheets("sheet1").Range(d).Resize(dic.count) = Application.Transpose(dic.Keys)
            Set kng = mbook.Sheets("sheet1").Range(d, mbook.Sheets("sheet1").Range(d).End(xlDown))
            For Each sng In kng
            For Each ar In myrange1
            count = count + Application.WorksheetFunction.CountIf(ar, sng)
            Next ar
            i = i + 1
            ReDim Preserve y(1 To 2, 1 To i)
            y(1, i) = count
            count = 0
            Next sng
            i = 0
            For Each sng In kng
            For Each ar In myrange2
            count = count + Application.WorksheetFunction.CountIf(ar, sng)
            Next ar
            i = i + 1
            y(2, i) = count
            count = 0
            Next sng
            book.Close False
            mbook.Sheets("sheet1").Range(d).Offset(0, 1).Resize(i, 2) = Application.Transpose(y)
            i = 0
            End If
            fn = Dir()
            Application.ScreenUpdating = False
            Loop
            End Sub

            Comment


            • #7


              Rmrekoj, after 58 posts you should know that all code must be wrapped in code tags.

              I am closing this thread until you add the tags to your code.
              We now have a reputation system in place. If my reply helped please "Like" the reply by clicking the "Like" icon at bottom right of my reply.

              Comment

              Working...
              X