how to select two names in column

[edu1102]

dear friends

I work excel files where the column B is a text this text repeat several columns down

question how to select the firsts two names om column b and copy and paste on another file

this is the sample

in other words i want to get the first two ABT and paste on another file and so on and so on with the next names

thank you in advance

best regards

edu

2012-01-31	ABT	21.00
2012-08-17	ABT	26.00
2012-10-17	ABT	28.00
2012-11-01	ABT	26.00
2012-12-17	ABT	26.00
2012-01-03	ACN	44.00
2012-02-08	ACN	47.00
2012-06-27	ACN	47.00
2012-12-20	ACN	58.00
2012-12-27	ACN	56.00
2012-08-24	ADBE	32.00
2012-08-29	ADBE	32.00
2012-08-31	ADBE	31.00
2012-02-23	ADI	31.00
2012-03-14	ADI	31.00
2012-04-02	ADI	31.00
2012-08-22	ADI	31.00
2012-01-10	ADM	22.00
2012-01-17	ADM	22.00
2012-01-31	ADM	22.00
2012-06-19	ADM	23.00
2012-08-10	ADM	20.00
2012-10-31	ADM	21.00
2012-11-05	ADM	20.00

 

[jolivanes]

How large (how many Rows) is the range of data?

 

[jolivanes]

This might be a solution.
Change references where required.

Sub Maybe_So()
Dim i As Long, j As Long, myAreas As Areas
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet3")
Application.ScreenUpdating = False
    For i = sh1.Cells(sh1.Rows.Count, 1).End(xlUp).Row To 3 Step -1
        If sh1.Cells(i, 2).Offset(-1).Value <> sh1.Cells(i, 2) Then sh1.Cells(i, 2).EntireRow.Insert Shift:=xlDown
    Next i
Set myAreas = sh1.Range("A2:C" & sh1.Cells(sh1.Rows.Count, 3).End(xlUp).Row).SpecialCells(2).Areas
    For j = 1 To myAreas.Count
        If myAreas(j).Rows.Count >= 2 Then
            myAreas(j).Cells(1).Resize(2, 3).Copy sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Offset(1)
        End If
    Next j
sh1.Columns(1).SpecialCells(4).EntireRow.Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub

 

[jolivanes]

If temporary inserting rows (as in code in Post #3) is not an option, this might do.
Don't know how fast or slow it is though.

Sub Maybe_So_Alternative()
Dim i As Long
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet3")
Application.ScreenUpdating = False
    For i = 2 To sh1.Cells(sh1.Rows.Count, 1).End(xlUp).Row - 1
        If sh1.Cells(i, 2).Offset(-1).Value <> sh1.Cells(i, 2).Value And sh1.Cells(i, 2).Offset(1).Value = sh1.Cells(i, 2).Value Then
            sh1.Cells(i, 1).Resize(2, 3).Copy sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Offset(1)
        End If
    Next i
Application.ScreenUpdating = True
End Sub

 

[jolivanes]

After you had a month to test, do you think you can let us know if any of the suggestions work.
That would be nice.