Extract desire groups copy and paste them into another locations

motilulla · Jul 17, 2019

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.

Book1

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

1

4

7

2

3

4

5

Gr

n1

n2

n3

n4

n5

*1

*2

Gr

n1

n2

n3

n4

n5

*1

*2

6

1

36

10

6

39

31

6

10

1

36

10

6

39

31

6

10

7

1

35

33

26

40

5

3

8

1

35

33

26

40

5

3

8

1

2

10

30

44

1

8

1

2

10

30

44

1

8

9

1

43

38

19

10

46

1

11

1

43

38

19

10

46

1

11

10

1

2

30

38

43

46

7

2

1

2

30

38

43

46

7

2

11

1

27

10

30

47

12

9

8

1

27

10

30

47

12

9

8

12

1

15

40

24

48

38

2

9

1

15

40

24

48

38

2

9

13

1

29

32

23

1

5

1

7

1

29

32

23

1

5

1

7

14

1

36

21

10

6

9

6

2

1

36

21

10

6

9

6

2

15

2

46

32

27

3

41

4

8

4

43

8

49

6

26

10

6

16

2

9

6

13

28

37

4

5

4

9

1

5

22

38

10

2

17

2

31

49

28

20

3

5

2

4

13

32

37

14

48

1

7

18

2

3

22

50

10

37

6

10

4

27

14

44

15

11

7

2

19

2

32

13

14

39

30

3

9

4

32

43

26

34

17

2

10

20

2

42

32

23

25

37

11

1

4

10

42

17

32

31

2

5

21

2

13

50

5

33

15

9

11

4

25

28

5

43

6

11

22

2

37

7

28

13

4

11

10

4

23

34

8

24

38

3

7

23

2

9

23

40

16

14

1

5

4

45

48

40

34

32

10

1

24

3

9

14

23

8

1

7

1

7

26

3

41

33

7

2

10

25

3

26

43

1

21

40

9

6

7

2

11

14

13

21

1

8

26

3

7

10

5

44

34

10

2

7

24

37

19

28

36

6

3

27

3

14

49

21

19

24

5

11

7

26

45

24

7

37

9

5

28

3

15

49

12

26

42

5

8

7

13

49

10

45

3

11

2

29

3

43

36

12

42

19

8

5

7

40

26

50

1

21

4

2

30

3

4

25

19

36

1

3

11

7

27

46

38

2

8

2

6

31

3

23

25

2

49

16

6

9

7

19

16

24

37

35

2

7

32

3

19

40

9

5

2

7

19

43

44

12

45

10

5

33

4

43

8

49

6

26

10

6

34

4

9

1

5

22

38

10

2

35

4

13

32

37

14

48

1

7

36

4

27

14

44

15

11

7

2

37

4

32

43

26

34

17

2

10

38

4

10

42

17

32

31

2

5

39

4

25

28

5

43

6

11

40

4

23

34

8

24

38

3

7

41

4

45

48

40

34

32

10

1

42

5

40

2

26

27

49

10

5

43

5

31

28

42

15

7

10

11

44

5

32

27

39

36

15

3

10

45

5

41

9

30

14

45

4

9

46

5

37

17

34

16

23

9

6

47

5

46

27

13

43

25

4

8

48

5

6

30

26

48

12

6

7

49

5

7

31

39

23

33

6

10

50

5

26

49

19

45

35

2

5

51

6

21

35

42

14

43

7

9

52

6

13

50

42

39

34

11

9

53

6

43

1

18

27

7

8

4

54

6

32

35

17

49

5

1

55

6

11

19

39

28

27

3

10

56

6

43

37

32

26

49

5

4

57

6

11

50

13

40

2

10

1

58

6

38

29

10

48

1

4

3

59

6

12

18

8

44

33

8

4

60

7

26

3

41

33

7

2

10

61

7

2

11

14

13

21

1

8

62

7

24

37

19

28

36

6

3

63

7

26

45

24

7

37

9

5

64

7

13

49

10

45

3

11

2

65

7

40

26

50

1

21

4

2

66

7

27

46

38

2

8

2

6

67

7

19

16

24

37

35

2

7

68

7

19

43

44

12

45

10

5

69

8

15

50

36

2

28

11

2

70

8

34

37

46

26

2

4

8

71

8

22

6

5

25

34

7

5

72

8

2

31

45

37

23

8

4

73

8

48

9

30

28

1

7

8

74

8

29

42

13

16

35

6

8

75

8

50

40

16

32

8

2

11

76

8

45

12

34

24

30

7

10

77

8

28

4

11

17

15

1

3

Sheet1

Thank you all

Excel 2000
Regards,
Moti

footoo · Jul 17, 2019

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.

motilulla · Jul 18, 2019

footoo said:

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

footoo · Jul 18, 2019

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

motilulla · Jul 18, 2019

footoo said:
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

footoo · Jul 18, 2019

motilulla said:
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.

motilulla · Jul 18, 2019

footoo said:

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

footoo · Jul 18, 2019

motilulla said:
strange re-entering the 1 in C6 it worked correctly

It means it didn't contain 1 - probably included a space.

motilulla · Jul 18, 2019

footoo said:
It means it didn't contain 1 - probably included a space.

Hello footoo, yes may be...

footoo said:
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

footoo · Jul 18, 2019

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

Extract desire groups copy and paste them into another locations

motilulla

Well-known Member

Excel Facts

footoo

Well-known Member

motilulla

Well-known Member

footoo

Well-known Member

motilulla

Well-known Member

footoo

Well-known Member

motilulla

Well-known Member

footoo

Well-known Member

motilulla

Well-known Member

footoo

Well-known Member

Similar threads

Forum statistics

Share this page

Extract desire groups copy and paste them into another locations

Well-known Member

Excel Facts

Well-known Member

Well-known Member

Well-known Member

Well-known Member

Well-known Member

Well-known Member

Well-known Member

Well-known Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock