Extract desire groups copy and paste them into another locations
Page 1 of 2 12 LastLast
Results 1 to 10 of 11

Thread: Extract desire groups copy and paste them into another locations

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

    Default Extract desire groups copy and paste them into another locations

    Hello,

    Sheet1 I got lottery results in the cells D6:J3500, cells C6:C3500 I have assigned the numbers 1 to 356 each group has 9 rows rest of the rows are empty at movement.

    In the area D1:J3 where I want to put the group number, which I want to extract it, can be 1 to 21 and copy past that groups in the columns M:T as shown example in the below this would be in the same "Sheet1", also if possible may I request one more VBA that can copy paste groups in to "Sheet2" in the columns C:J please.

    #E0E0F0 " />#E0E0F0 ;text-align: center;color: #161120">
    ABCDEFGHIJKLMNOPQRST
    1147
    2
    3
    4
    5Grn1n2n3n4n5*1*2Grn1n2n3n4n5*1*2
    613610639316101361063931610
    7135332640538135332640538
    81210304411812103044118
    91433819104611114338191046111
    10123038434672123038434672
    1112710304712981271030471298
    1211540244838291154024483829
    131293223151712932231517
    141362110696213621106962
    15246322734148443849626106
    162961328374549152238102
    172314928203524133237144817
    1823225010376104271444151172
    19232131439303943243263417210
    20242322325371114104217323125
    212135053315911442528543611
    222377281341110423348243837
    2329234016141544548403432101
    243914238171726341337210
    25326431214096721114132118
    263710544341027243719283663
    2731449211924511726452473795
    2831549122642587134910453112
    293433612421985740265012142
    3034251936131172746382826
    313232524916697191624373527
    32331940955271943441245105
    33443849626106
    3449152238102
    354133237144817
    364271444151172
    3743243263417210
    384104217323125
    39442528543611
    40423348243837
    4144548403432101
    425402262749105
    4353128421571011
    4453227393615310
    45541930144549
    465371734162396
    475462713432548
    48563026481267
    495731392333610
    505264919453525
    516213542144379
    5261350423934119
    5364311827784
    54632351749551
    5561119392827310
    566433732264954
    576115013402101
    58638291048143
    59612188443384
    60726341337210
    61721114132118
    627243719283663
    63726452473795
    647134910453112
    65740265012142
    6672746382826
    677191624373527
    6871943441245105
    698155036228112
    70834374626248
    7182265253475
    72823145372384
    7384893028178
    748294213163568
    758504016328211
    7684512342430710
    77828411171513

    #E0E0F0 ;color: #161120">Sheet1





    Thank you all

    Excel 2000
    Regards,
    Moti

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

    Default Re: Extract desire groups copy and paste them into another locations

    cells C6:C3500 I have assigned the numbers 1 to 356 each group has 9 rows rest of the rows are empty at movement.
    That works out at C6:C3209

    To paste to same sheet :
    Code:
    Dim cel As Range
    [M6:T3209].ClearContents
    With [M6:M3209].Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    If WorksheetFunction.CountA([D1:J3]) = 0 Then Exit Sub
    On Error Resume Next
    For Each cel In [D1:J3].SpecialCells(xlCellTypeConstants)
        [C:C].Find(cel).Resize(9, 8).Copy Cells(Rows.Count, "M").End(3)(2)
    Next
    On Error GoTo 0
    Use similar code to paste to other sheet.
    Last edited by footoo; Jul 17th, 2019 at 10:30 PM.

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

    Default Re: Extract desire groups copy and paste them into another locations

    Quote Originally Posted by footoo View Post
    That works out at C6:C3209

    To paste to same sheet :
    Code:
    Dim cel As Range
    [M6:T3209].ClearContents
    With [M6:M3209].Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    If WorksheetFunction.CountA([D1:J3]) = 0 Then Exit Sub
    On Error Resume Next
    For Each cel In [D1:J3].SpecialCells(xlCellTypeConstants)
        [C:C].Find(cel).Resize(9, 8).Copy Cells(Rows.Count, "M").End(3)(2)
    Next
    On Error GoTo 0
    Use similar code to paste to other sheet.
    footoo, the macro is working, as it should perfect. Please can you suggest couple of modifications?

    1st-macro copy past in the same Sheet1 all the selected groups in the columns M:T no problem at all, what if I do not have the header placed in the M5:T5 it start copy paste from cell M2 could it be modified to start from M6 in the case header is not there


    2nd-what lines I need to add for example copy the groups from Sheet1 to Sheet2


    Thank you so much for your help


    Kind Regards,

    Moti

    Last edited by motilulla; Jul 18th, 2019 at 01:11 AM.

  4. #4
    Board Regular
    Join Date
    Sep 2016
    Posts
    2,516
    Post Thanks / Like
    Mentioned
    34 Post(s)
    Tagged
    1 Thread(s)

    Default Re: Extract desire groups copy and paste them into another locations

    Code:
    Dim cel As Range, rw%
    [C5:J5].Copy [M5]
    [M6:T3209].ClearContents
    [M6:M3209].Interior.Pattern = xlNone
    Sheets("Sheet2").[C2:J3205].ClearContents
    Sheets("Sheet2").[C2:C3205].Interior.Pattern = xlNone
    If WorksheetFunction.CountA([D1:J3]) = 0 Then Exit Sub
    On Error Resume Next
    For rw = 1 To 3
        For Each cel In Cells(rw, "D").Resize(, 7).SpecialCells(xlCellTypeConstants)
            With [C:C].Find(cel, LookAt:=xlWhole).Resize(9, 8)
                .Copy Cells(Rows.Count, "M").End(3)(2)
                .Copy Sheets("Sheet2").Cells(Rows.Count, "C").End(3)(2)
            End With
        Next
    Next
    On Error GoTo 0
    Last edited by footoo; Jul 18th, 2019 at 01:50 AM.

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

    Default Re: Extract desire groups copy and paste them into another locations

    Quote Originally Posted by footoo View Post
    Code:
    Dim cel As Range, rw%
    On Error GoTo 0
    footoo, thank you for quick modifications, please can you check if in the cell D1 is placed "1" I observed it is copying first group from row7 (not from the row6) and than rest groups are ok. Secondly it copies in sheet2 but start from row 2 not from row6

    Kind Regards,

    Moti


  6. #6
    Board Regular
    Join Date
    Sep 2016
    Posts
    2,516
    Post Thanks / Like
    Mentioned
    34 Post(s)
    Tagged
    1 Thread(s)

    Default Re: Extract desire groups copy and paste them into another locations

    Quote Originally Posted by motilulla View Post
    please can you check if in the cell D1 is placed "1" I observed it is copying first group from row7 (not from the row6)
    It's working correctly for me. Try re-entering the 1 in C6.
    Code:
    Dim cel As Range, rw%
    [C5:J5].Copy [M5]
    [C5:J5].Copy Sheets("Sheet2").[C5]
    [M6:T3209].ClearContents
    [M6:M3209].Interior.Pattern = xlNone
    Sheets("Sheet2").[C6:J3209].ClearContents
    Sheets("Sheet2").[C6:C3209].Interior.Pattern = xlNone
    If WorksheetFunction.CountA([D1:J3]) = 0 Then Exit Sub
    On Error Resume Next
    For rw = 1 To 3
        For Each cel In Cells(rw, "D").Resize(, 7).SpecialCells(xlCellTypeConstants)
            With [C5:C3209].Find(cel, LookAt:=xlWhole).Resize(9, 8)
                .Copy Cells(Rows.Count, "M").End(3)(2)
                .Copy Sheets("Sheet2").Cells(Rows.Count, "C").End(3)(2)
            End With
        Next
    Next
    On Error GoTo 0
    What about the colour fills in column M?
    Do you want them alternating or the same as the colour in column C for that number?
    At the moment the code does the latter.
    Last edited by footoo; Jul 18th, 2019 at 03:00 AM.

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

    Default Re: Extract desire groups copy and paste them into another locations

    Quote Originally Posted by footoo View Post
    It's working correctly for me. Try re-entering the 1 in C6.
    Code:
    Dim cel As Range, rw%
    [C5:J5].Copy [M5]
    [C5:J5].Copy Sheets("Sheet2").[C5]
    [M6:T3209].ClearContents
    [M6:M3209].Interior.Pattern = xlNone
    Sheets("Sheet2").[C6:J3209].ClearContents
    Sheets("Sheet2").[C6:C3209].Interior.Pattern = xlNone
    If WorksheetFunction.CountA([D1:J3]) = 0 Then Exit Sub
    On Error Resume Next
    For rw = 1 To 3
        For Each cel In Cells(rw, "D").Resize(, 7).SpecialCells(xlCellTypeConstants)
            With [C5:C3209].Find(cel, LookAt:=xlWhole).Resize(9, 8)
                .Copy Cells(Rows.Count, "M").End(3)(2)
                .Copy Sheets("Sheet2").Cells(Rows.Count, "C").End(3)(2)
            End With
        Next
    Next
    On Error GoTo 0
    What about the colour fills in column M?
    Do you want them alternating or the same as the colour in column C for that number?
    At the moment the code does the latter.
    footoo, strange re-entering the 1 in C6 it worked correctly and also it is copying fine in sheet2 from row 6. Colour fill in the Column "M" it is perfect I want the same.

    All has been stored as required perfectly


    Thank you for your help and time to solve all issues


    Kind Regards,

    Moti
    Last edited by motilulla; Jul 18th, 2019 at 03:13 AM.

  8. #8
    Board Regular
    Join Date
    Sep 2016
    Posts
    2,516
    Post Thanks / Like
    Mentioned
    34 Post(s)
    Tagged
    1 Thread(s)

    Default Re: Extract desire groups copy and paste them into another locations

    Quote Originally Posted by motilulla View Post
    strange re-entering the 1 in C6 it worked correctly
    It means it didn't contain 1 - probably included a space.

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

    Default Re: Extract desire groups copy and paste them into another locations

    Quote Originally Posted by footoo View Post
    It means it didn't contain 1 - probably included a space.
    Hello footoo, yes may be...

    Quote Originally Posted by footoo View Post
    What about the colour fills in column M?
    Do you want them alternating or the same as the colour in column C for that number?
    At the moment the code does the latter.
    footoo, I am re thinking on it and you have the reason I need to get altered colouring in the column M because when I select continuous even or odd groups they all get mix up does it is possible to re colour column M change the colours after every 9 rows?

    Kind Regards,

    Moti
    Last edited by motilulla; Jul 18th, 2019 at 04:23 AM.

  10. #10
    Board Regular
    Join Date
    Sep 2016
    Posts
    2,516
    Post Thanks / Like
    Mentioned
    34 Post(s)
    Tagged
    1 Thread(s)

    Default Re: Extract desire groups copy and paste them into another locations

    Code:
    Dim cel As Range, rw%, c%, x%
    [C5:J5].Copy [M5]
    [C5:J5].Copy Sheets("Sheet2").[C5]
    [M6:T3209].ClearContents
    [M6:M3209].Interior.Pattern = xlNone
    Sheets("Sheet2").[C6:J3209].ClearContents
    Sheets("Sheet2").[C6:C3209].Interior.Pattern = xlNone
    If WorksheetFunction.CountA([D1:J3]) = 0 Then Exit Sub
    On Error Resume Next
    For rw = 1 To 3
        For Each cel In Cells(rw, "D").Resize(, 7).SpecialCells(xlCellTypeConstants)
            With [C5:C3209].Find(cel, LookAt:=xlWhole).Resize(9, 8)
                .Copy Cells(Rows.Count, "M").End(3)(2)
                .Copy Sheets("Sheet2").Cells(Rows.Count, "C").End(3)(2)
            End With
        Next
    Next
    For c = 6 To Cells(Rows.Count, "M").End(3).Row Step 9
        If x = 0 Then
            Cells(c, "M").Resize(9).Interior.ColorIndex = 6
            Sheets("Sheet2").Cells(c, "C").Resize(9).Interior.ColorIndex = 6
            x = 1
        Else
            Cells(c, "M").Resize(9).Interior.ColorIndex = 38
            Sheets("Sheet2").Cells(c, "C").Resize(9).Interior.ColorIndex = 38
            x = 0
        End If
    Next
    On Error GoTo 0

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
  •