Extract desire groups copy and paste them into another locations

motilulla

Well-known Member
Joined
Feb 13, 2008
Messages
2,353
Office Version
  1. 2010
Hello,</SPAN></SPAN>

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.</SPAN></SPAN>

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. </SPAN></SPAN>


Book1
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
Sheet1


Thank you all</SPAN></SPAN>

Excel 2000</SPAN></SPAN>
Regards,</SPAN>
Moti</SPAN>
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
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:
Upvote 0
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?</SPAN></SPAN>

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
</SPAN></SPAN>

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

Thank you so much for your help
</SPAN></SPAN>

Kind Regards,
</SPAN></SPAN>
Moti :)
</SPAN></SPAN>
 
Last edited:
Upvote 0
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:
Upvote 0
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 </SPAN></SPAN>

Kind Regards,
</SPAN></SPAN>
Moti
</SPAN></SPAN>
 
Upvote 0
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:
Upvote 0
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 (y)
</SPAN></SPAN>

Thank you for your help and time to solve all issues
</SPAN></SPAN>

Kind Regards,
</SPAN></SPAN>
Moti :)
</SPAN></SPAN>
 
Last edited:
Upvote 0
It means it didn't contain 1 - probably included a space.
Hello footoo, yes may be...

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?</SPAN></SPAN>

Kind Regards,
</SPAN></SPAN>
Moti
</SPAN></SPAN>
 
Last edited:
Upvote 0
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
 
Upvote 0
Solution

Forum statistics

Threads
1,213,497
Messages
6,113,999
Members
448,541
Latest member
iparraguirre89

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top