copy data to different columns

[paulsolar]

Hi All

I have in Sheet1 Column A the data for about 3000 contacts which I want to split into individual contacts on sheet 2 going accross the columns.

The problem is that some of the contacts use 4 rows, others 5 and some 6. This is causing me all sorts of problems.

The only saving grace that I think may help is that at the end of every contact is a cell with the telephone number followed by the text "More information" for example:

Existing Format

[TABLE="width: 357"]
<colgroup><col></colgroup><tbody>[TR]
[TD][TABLE="width: 357"]
<colgroup><col></colgroup><tbody>[TR]
[TD]Heatcare [/TD]
[/TR]
[TR]
[TD]Office 2, Enterprise Centre[/TD]
[/TR]
[TR]
[TD]Hill Road[/TD]
[/TR]
[TR]
[TD]Aberdare[/TD]
[/TR]
[TR]
[TD]NP16 7AX[/TD]
[/TR]
[TR]
[TD]012222222222More information[/TD]
[/TR]
[TR]
[TD]XYZ Plumbing and Electrical Engineers[/TD]
[/TR]
[TR]
[TD]1 Union Street[/TD]
[/TR]
[TR]
[TD]Cardiff[/TD]
[/TR]
[TR]
[TD]CF11 6ER[/TD]
[/TR]
[TR]
[TD]0111111111More information[/TD]
[/TR]
[TR]
[TD]Mikes Training[/TD]
[/TR]
[TR]
[TD]somewhere Drive[/TD]
[/TR]
[TR]
[TD]West somewhere[/TD]
[/TR]
[TR]
[TD]Aberdeen[/TD]
[/TR]
[TR]
[TD]AB88 3AL[/TD]
[/TR]
[TR]
[TD]011119991392/07717704444More information

New Format


[/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="width: 1088"]
<colgroup><col><col><col><col><col><col></colgroup><tbody>[TR]
[TD]Heatcare [/TD]
[TD]Office 2, Enterprise Centre[/TD]
[TD]Hill Road[/TD]
[TD]Aberdare[/TD]
[TD]NP16 7AX[/TD]
[TD]012222222222More information[/TD]
[/TR]
[TR]
[TD]XYZ Plumbing and Electrical Engineers[/TD]
[TD]1 Union Street[/TD]
[TD]Cardiff[/TD]
[TD]CF11 6ER[/TD]
[TD]0111111111More information[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mikes Training[/TD]
[TD]somewhere Drive[/TD]
[TD]West somewhere[/TD]
[TD]Aberdeen[/TD]
[TD]AB88 3AL[/TD]
[TD]011119991392/07717704444More information
[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
Any help would be greatfully appreciated as I've almost pulled whats left of my hair

Cheers

Paul

 

[Fluff]

How about

Sub SplitRecords()

   Dim Fnd As Range
   Dim Fnd2 As Range
   Dim Cols As Long
   Dim Cnt As Long
   
   With Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")
      Set Fnd = .Range("A1")
      For Cnt = 1 To WorksheetFunction.CountIf(.Columns(1), "*more information")
      Set Fnd2 = .Range("A:A").Find("more information", Fnd, , xlPart, , , False, , False)
         Cols = Fnd2.Row - Fnd.Row + 1
         Sheets("[COLOR=#ff0000]Sheet2[/COLOR]").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, Cols).Value _
            = Application.Transpose(.Range(Fnd, Fnd2).Value)
         Set Fnd = Fnd2.Offset(1)
      Next Cnt
   End With
End Sub

 

[paulsolar]

Hi Fluff

Sorry for the delay in responding, I was stuck on the M4 getting home.

You came to my rescue again, worked like a charm thanks. It will save my wife a days work tomorrow sorting it out.

I almost feel like saying good luck for the rugby on Saturday, but only almost. (no need i think as you'll win anyway)

cheers from a very greatful welshman

regards

Paul

 

[Fluff]

Glad to help & thanks for the feedback.

ps. If we don't win I might not help you again

 

[paulsolar]

I'll send you another little teaser on monday then, i think I'm safe in saying that