Extract selected number and move them into another locations
Results 1 to 5 of 5

Thread: Extract selected number and move them into another locations

  1. #1
    Board Regular
    Join Date
    Feb 2008
    Posts
    1,746
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Extract selected number and move them into another locations

    Hello,

    I got lottery results in the cells D6:J1000, and in the cells C6:C1000 I have numbers from 1 to 50.

    In the area D1:J3 where I want to put the number, which I want to extract, could be any between 1 to 50 and copy past that all rows in the columns M:T the example below is shown with 5 numbers, once these numbers are copy paste in the column M:T I want column "M" number could be colour with alternate colour as shown

    #E0E0F0 " />#E0E0F0 ;text-align: center;color: #161120">
    ABCDEFGHIJKLMNOPQRST
    11781012
    2
    3
    4
    5Numbersn1n2n3n4n5*1*2Numbersn1n2n3n4n5*1*2
    613610639316101361063931610
    723533264053812103044118
    81210304411813621106962
    944338191046111143849626106
    1052303843467219152238102
    1182710304712981133237144817
    12101540244838291271444151172
    1312293223151711350423934119
    1413621106962132351749551
    15746322734148126341337210
    1679613283745746322734148
    1773149282035279613283745
    185322501037610731492820352
    195321314393039721114132118
    20542322325371117243719283663
    219135053315911726452473795
    2283772813411108271030471298
    235923401614158377281341110
    2449142381718115013402101
    2532643121409681943441245105
    2627105443410210154024483829
    27214492119245111038291048143
    282154912264258122932231517
    2924336124219851263026481267
    302425193613111212188443384
    31223252491669
    322319409552
    33143849626106
    3419152238102
    351133237144817
    361271444151172
    37163243263417210
    3816104217323125
    391642528543611
    401823348243837
    41184548403432101
    4218402262749105
    43203128421571011
    44213227393615310
    452041930144549
    4621371734162396
    479462713432548
    481263026481267
    4915731392333610
    5018264919453525
    5121213542144379
    5211350423934119
    5324311827784
    54132351749551
    5541119392827310
    565433732264954
    578115013402101
    581038291048143
    591212188443384
    60126341337210
    61721114132118
    627243719283663
    63726452473795
    645134910453112
    65540265012142
    6652746382826
    679191624373527
    6881943441245105
    695155036228112
    70434374626248
    7132265253475
    72223145372384
    7324893028178
    742294213163568
    752504016328211
    7624512342430710
    77228411171513

    #E0E0F0 ;color: #161120">Sheet1





    Thank you all

    Excel 2000
    Regards,
    Moti

  2. #2
    MrExcel MVP
    Join Date
    Jan 2008
    Posts
    14,834
    Post Thanks / Like
    Mentioned
    26 Post(s)
    Tagged
    12 Thread(s)

    Default Re: Extract selected number and move them into another locations

    Try this:-
    Code:
    Sub MG18Jul51
    Dim Ray As Variant, n As Long, Q As Variant, Ac As Long, Dic As Object
    Ray = Cells(5, 3).CurrentRegion
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    
    For n = 2 To UBound(Ray, 1)
        If Not Dic.exists(Ray(n, 1)) Then
            ReDim nray(1 To 7, 1 To 1)
                For Ac = 2 To UBound(Ray, 2)
                    nray(Ac - 1, 1) = Ray(n, Ac)
                Next Ac
                Dic.Add Ray(n, 1), nray
            Else
              Q = Dic(Ray(n, 1))
              ReDim Preserve Q(1 To 7, 1 To UBound(Q, 2) + 1)
                For Ac = 2 To UBound(Ray, 2)
                    Q(Ac - 1, UBound(Q, 2)) = Ray(n, Ac)
                Next Ac
               Dic(Ray(n, 1)) = Q
                
            End If
       
    Next n
    
    Dim K As Variant
    Dim Rng As Range, Dn As Range, c As Long, col As Long
    c = 6: col = 38
    
    Set Rng = Range("D1:J3")
    For Each Dn In Rng
        If Dic.exists(Dn.Value) Then
            col = IIf(col = 6, 38, 6)
            Cells(c, "M").Resize(UBound(Dic(Dn.Value), 2)) = Dn.Value
            Cells(c, "M").Resize(UBound(Dic(Dn.Value), 2)).Interior.ColorIndex = col
            Cells(c, "N").Resize(UBound(Dic(Dn.Value), 2), 7) = Application.Transpose(Dic(Dn.Value))
            c = c + UBound(Dic(Dn.Value), 2)
        End If
    
    Next Dn
    
    End Sub
    Regards Mick

  3. #3
    Board Regular
    Join Date
    Feb 2008
    Posts
    1,746
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Extract selected number and move them into another locations

    Quote Originally Posted by MickG View Post
    Try this:-
    Code:
    Sub MG18Jul51
    Dim Ray As Variant, n As Long, Q As Variant, Ac As Long, Dic As Object
    Ray = Cells(5, 3).CurrentRegion
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    
    For n = 2 To UBound(Ray, 1)
        If Not Dic.exists(Ray(n, 1)) Then
            ReDim nray(1 To 7, 1 To 1)
                For Ac = 2 To UBound(Ray, 2)
                    nray(Ac - 1, 1) = Ray(n, Ac)
                Next Ac
                Dic.Add Ray(n, 1), nray
            Else
              Q = Dic(Ray(n, 1))
              ReDim Preserve Q(1 To 7, 1 To UBound(Q, 2) + 1)
                For Ac = 2 To UBound(Ray, 2)
                    Q(Ac - 1, UBound(Q, 2)) = Ray(n, Ac)
                Next Ac
               Dic(Ray(n, 1)) = Q
                
            End If
       
    Next n
    
    Dim K As Variant
    Dim Rng As Range, Dn As Range, c As Long, col As Long
    c = 6: col = 38
    
    Set Rng = Range("D1:J3")
    For Each Dn In Rng
        If Dic.exists(Dn.Value) Then
            col = IIf(col = 6, 38, 6)
            Cells(c, "M").Resize(UBound(Dic(Dn.Value), 2)) = Dn.Value
            Cells(c, "M").Resize(UBound(Dic(Dn.Value), 2)).Interior.ColorIndex = col
            Cells(c, "N").Resize(UBound(Dic(Dn.Value), 2), 7) = Application.Transpose(Dic(Dn.Value))
            c = c + UBound(Dic(Dn.Value), 2)
        End If
    
    Next Dn
    
    End Sub
    Regards Mick
    Wow Mick, the macro result at a glance, result stored as request.

    I appreciate a lot so kind of your help and time to solve this request.


    Kind Regards,

    Moti


  4. #4
    MrExcel MVP
    Join Date
    Jan 2008
    Posts
    14,834
    Post Thanks / Like
    Mentioned
    26 Post(s)
    Tagged
    12 Thread(s)

    Default Re: Extract selected number and move them into another locations

    You're welcome

  5. #5
    Board Regular
    Join Date
    Sep 2016
    Posts
    2,560
    Post Thanks / Like
    Mentioned
    36 Post(s)
    Tagged
    1 Thread(s)

    Default Re: Extract selected number and move them into another locations

    If the number of entries in D1:J3 might be fewer than the entries when the macro was previously run, need to add code that first clears the data in M:T and the fill colors in column M.

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •