Copie

[gnusmas]

Hi friend i have Sheet1 with group of numbers i need vba code to copie just group if last cell have 15

Exemple:

10	17	41
05	11	19
01	19	22
11	12	15
01	07	18
06	08	22
12	13	14
06	25	26
19	21	22
07	14	15
03	09	21
05	10	22

<tbody>
</tbody>

Sheet2

11	12	15
01	07	18
06	08	22
07	14	15
03	09	21
05	10	22

<tbody>
</tbody>

Thank you for help

 

[KeepTrying]

Hi,

I assumed layout is the same as on your sample screen:

Sub CopyGroup15()


Dim Rng As Range
Dim i As Long, X As Long, Y As Long


Application.ScreenUpdating = False


Set Rng = ThisWorkbook.Sheets("Sheet1").UsedRange
Sheets("Sheet2").Cells.Clear 'delete cells on "Sheet2"


Y = 4
X = 1
For i = 1 To Rng.Rows.Count Step Y
    If Rng.Cells(i, 3) = 15 Then
        Sheets("Sheet1").Range(Rng.Cells(i, 1).Address, Rng.Cells(i + 2, 3).Address).Copy _
        Sheets("Sheet2").Cells(X, 1)
        X = X + Y
    End If
Next i


Application.ScreenUpdating = True


End Sub

I hope it'll work for you.

Kind Regards,

 

[gnusmas]

thank you friend i have just problem when 15 is repeted like this!!

11	12	15
01	07	15
06	08	22

<colgroup><col span="3"></colgroup><tbody>
</tbody>

as you see is just one group!! i need just copie each group when 15 on head and last cell!

 

[hiker95]

gnusmas,

1. What version of Excel and Windows are you using?

2. Are you using a PC or a Mac?

If I understand you correctly, here is another macro for you to consider, that will search each group in Sheet1 column C for the value 15.

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub CopyGroups15()
' hiker95, 03/28/2015, ME844183
Dim w1 As Worksheet, w2 As Worksheet
Dim Area As Range, sr As Long, er As Long, nr As Long, c As Range
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
w2.Columns("A:C").ClearContents
nr = 1
With w1
  For Each Area In w1.Range("C1", w1.Range("C" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
    With Area
      sr = .Row
      er = sr + .Rows.Count - 1
      Set c = w1.Range("C" & sr & ":C" & er).Find(15, LookAt:=xlWhole)
      If Not c Is Nothing Then
        w2.Cells(nr, 1).Resize(3, 3).Value = w1.Range("A" & sr & ":C" & er).Value
        nr = nr + 4
      End If
    End With
  Next Area
End With
With w2
  .Columns("A:C").AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the CopyGroups15 macro.

 

[gnusmas]

Thank you hicker95 great job i am using excel 2007
i have another Sheet 1 with the following groups separate with one row i need just extract each group with last cell 49

18	21	26	34	41	49
03	06	08	29	37	38
24	25	30	31	33	43
08	09	32	34	46	48
13	24	30	32	33	46
17	24	26	30	32	37

<tbody>
</tbody>

14	19	21	31	32	45
13	21	37	44	45	47
01	05	09	33	35	40
01	07	13	14	20	32
09	22	27	35	39	46
02	04	08	30	38	44

<tbody>
</tbody>

14	18	27	33	38	42
03	04	19	34	43	49
09	29	33	39	43	45
09	13	16	34	36	37
06	15	27	28	34	46
02	04	16	23	26	30

<tbody>
</tbody>

03	11	16	28	39	49
09	10	29	41	46	47
06	13	22	38	41	45
04	24	29	32	34	43
01	03	07	32	41	46
10	11	13	15	18	30

<tbody>
</tbody>

10	23	24	28	35	42
03	04	21	34	42	43
02	09	18	36	44	49
23	25	29	31	35	46
02	09	13	26	40	46
14	30	31	34	38	48

<tbody>
</tbody>

Sheet2

18	21	26	34	41	49
03	06	08	29	37	38
24	25	30	31	33	43
08	09	32	34	46	48
13	24	30	32	33	46
17	24	26	30	32	37

<tbody>
</tbody>

03	11	16	28	39	49
09	10	29	41	46	47
06	13	22	38	41	45
04	24	29	32	34	43
01	03	07	32	41	46
10	11	13	15	18	30

<tbody>
</tbody>

thank you for help!

 

[hiker95]

gnusmas,

Thank you hicker95 great job

Thanks for the feedback.

You are very welcome. Glad I could help.

i have another Sheet 1 with the following groups separate with one row i need just extract each group with last cell 49

Be back in a little while.

 

[hiker95]

gnusmas,

Here is a new macro solution, based on your new data structure, for you to consider.

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub CopyGroups49()
' hiker95, 03/28/2015, ME844183
Dim w1 As Worksheet, w2 As Worksheet
Dim Area As Range, sr As Long, er As Long, nr As Long, n As Range
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
w2.Columns("A:F").ClearContents
nr = 1
With w1
  For Each Area In w1.Range("F1", w1.Range("F" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
    With Area
      sr = .Row
      er = sr + .Rows.Count - 1
      Set n = w1.Range("F" & sr & ":F" & er).Find(49, LookAt:=xlWhole)
      If Not n Is Nothing Then
        w2.Cells(nr, 1).Resize(6, 6).Value = w1.Range("A" & sr & ":F" & er).Value
        nr = nr + 7
      End If
    End With
  Next Area
End With
With w2
  .Columns("A:F").AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the CopyGroups49 macro.

 

[gnusmas]

Hi, hicker95 i have run your code i get all groups like this

18	21	26	34	41	49
03	06	08	29	37	38
24	25	30	31	33	43
08	09	32	34	46	48
13	24	30	32	33	46
17	24	26	30	32	37
10	23	24	28	35	42
03	04	21	34	42	43
02	09	18	36	44	49
23	25	29	31	35	46
02	09	13	26	40	46
14	30	31	34	38	48
14	18	27	33	38	42
03	04	19	34	43	49
09	29	33	39	43	45
09	13	16	34	36	37
06	15	27	28	34	46
02	04	16	23	26	30
03	11	16	28	39	49
09	10	29	41	46	47
06	13	22	38	41	45
04	24	29	32	34	43
01	03	07	32	41	46
10	11	13	15	18	30

<tbody>
</tbody>

not just 49 in first row!!

 

[hiker95]

gnusmas,

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub CopyGroups49infirstrow()
' hiker95, 03/28/2015, ME844183
Dim w1 As Worksheet, w2 As Worksheet
Dim Area As Range, sr As Long, er As Long, nr As Long
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
w2.Columns("A:F").ClearContents
nr = 1
With w1
  For Each Area In w1.Range("F1", w1.Range("F" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
    With Area
      sr = .Row
      er = sr + .Rows.Count - 1
      If w1.Range("F" & sr) = 49 Then
        w2.Cells(nr, 1).Resize(.Rows.Count, 6).Value = w1.Range("A" & sr & ":F" & er).Value
        nr = nr + 7
      End If
    End With
  Next Area
End With
With w2
  .Columns("A:F").AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Ten run the CopyGroups49infirstrow macro.

 

[KeepTrying]

Hi,

I believe my code worked correctly (it handled array as one group if top right value was equal to 15). Now I changed my code in line with your new requirements. It'll work if you have two empty rows between groups. If you have other than two empty rows between groups please let me know and I'll update my code.

Sub CopyGroup15_revised()


Dim Rng As Range
Dim i As Long, X As Long, Y As Long


Application.ScreenUpdating = False


Set Rng = ThisWorkbook.Sheets("Sheet1").UsedRange
Sheets("Sheet2").Cells.Clear 'delete cells on "Sheet2"


Y = 8
X = 1
For i = 1 To Rng.Rows.Count Step Y
    If Rng.Cells(i, 6) = 49 Then
        Sheets("Sheet1").Range(Rng.Cells(i, 1).Address, Rng.Cells(i + 5, 6).Address).Copy _
        Sheets("Sheet2").Cells(X, 1)
        X = X + Y
    End If
Next i


Application.ScreenUpdating = True


End Sub