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
In article <(E-Mail Removed)>,
Uninvisible <(E-Mail Removed)> wrote:
> 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 n...@internet.com 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 n...@internet.com CATALOGS 03/08/06
> A18 na...@internet.com 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
|
Similar Threads
