Copy Data with transpose to Sheet2 from Sheet1 between 2 email address.

[tajulit]

Hi All,
I have faced a big problem. I have huge data with name, address, email. I want to copy data between 2 email address to sheet2 & transpose.

For example:
Sheet 1:
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Mr Karim[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]234, by lane[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]abc@gmail.com[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mr rashed[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]015987456[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]365 by lane mc road[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]amik@yahoo.com[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mr Sumon[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]sumon@bd.net[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]khaled ali[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]sumr road[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]sumil@gmail.com[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Sheet 2: Output
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Mr Karim[/TD]
[TD]234, by lane[/TD]
[TD]abc@gmail.com[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mr rashed[/TD]
[TD]015987456[/TD]
[TD]365 by lane mc road[/TD]
[TD]amik@yahoo.com[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mr Sumon[/TD]
[TD]sumon@bd.net[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]khaled ali[/TD]
[TD]sumr road[/TD]
[TD]sumil@gmail.com[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


Thanks in advance

 

[tajulit]

Anyone can help me??

 

[Fluff]

How about

Sub SplitonAt()
   Dim Rng As Range
   Sheets("Sheet1").Activate
   With Range("B1", Range("A" & Rows.Count).End(xlUp).Offset(, 1))
      .Value = Evaluate(Replace("if(isnumber(find(""@"",#)),true,"""")", "#", .Offset(, -1).Address))
      For Each Rng In .SpecialCells(xlBlanks).Areas
         Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, Rng.Count + 1).Value = Application.Transpose(Rng.Offset(, -1).Resize(Rng.Count + 1))
      Next Rng
      .Clear
   End With
End Sub

 

[tajulit]

Hi Fluff,
Thanks a lot. It works fine.

 

[Fluff]

Glad to help & thanks for the feedback