Creating a Variable Range

[Uninvisible]

I am using the following code to copy a range of cells in Column A and
to paste (special transpose) the range in another area of the
spreadsheet. Only problem is that I have fixed the range here to be
the first 10 cells but it is a variable range which should end when it
has included the last cell to contain an e-mail address following a
cell which has a fixed value (and each range will have this fixed
value):

A1 Erica Smith
A2 Vice President
A3 Company, Inc.
A4 710 Bridgeport Avenue
A5 Southfield, MI 48076
A6 (555)555-5555
A7 (555)555-5555
A8 E-Mail Address Associated Contact Created By Date
A9 (e-mail address removed) EGOKCE 03/08/06
A10 Darby Smith
A11 Vice President
A12 Company, Inc.
A13 710 Bridgeport Avenue
A14 Southfield, MI 48076
A15 (555)555-5555
A16 E-Mail Address Associated Contact Created By Date
A17 (e-mail address removed) CATALOGS 03/08/06
A18 (e-mail address removed) HINGERMA 03/22/06
A19 Carol Smith
A20 Vice President
A21 Company, Inc.
A22 710 Bridgeport Avenue
A23 Southfield, MI 48076
A24 (555)555-5555
A25 E-Mail Address Associated Contact Created By Date
A26 Mike Smith
A27 Vice President

So, the code should auto-identify A1:A9, A10:A18 and A19:A25 as ranges
which will be copied and transposed. It should do this for all 30000
ecords in Column A. Here is what I have so far, any thoughts:

Sub Transpose1()

Dim cnt As Integer
Do
Set rng = Selection.Offset.Resize(10)
Application.CutCopyMode = False
rng.Copy
Range("G" & rng.Row).Select
Do While ActiveCell.Value <> ""
ActiveCell.Offset(1, 0).Select
Loop
Selection.PasteSpecial Transpose:=True
rng.Delete Shift:=xlUp
Range("A" & ActiveCell.Row).Select
cnt = 1
Do
ActiveCell.Offset(-1, 0).Select
cnt = cnt + 1
Loop Until ActiveCell.Value & "" = ""
If cnt < 3 Then
Exit Do
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
End Sub

 

[JE McGimpsey]

One way:

Public Sub Transpose1()
Const csSearch As String = "E-Mail Address"
Dim rStart As Range
Dim rDest As Range
Dim nCount As Long
Dim bFound As Boolean

Set rStart = Range("A1")
Set rDest = Range("G1")
Do While rStart.Text <> vbNullString
bFound = False
nCount = 1
Do
With rStart
If bFound Then
If InStr(.Offset(nCount, 0).Text, "@") = 0 Then
.Resize(nCount).Copy
rDest.PasteSpecial Transpose:=True
Set rDest = rDest.Offset(1, 0)
Set rStart = .Offset(nCount)
Exit Do
End If
Else
bFound = InStr(1, .Offset(nCount, 0).Text, csSearch)
End If
End With
nCount = nCount + 1
Loop
Loop
End Sub

 

[Uninvisible]

Perfect. Thank you.