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

Heatcare Office 2, Enterprise Centre Hill Road Aberdare NP16 7AX 012222222222More information XYZ Plumbing and Electrical Engineers 1 Union Street Cardiff CF11 6ER 0111111111More information Mikes Training somewhere Drive West somewhere Aberdeen AB88 3AL 011119991392/07717704444More information New Format <colgroup><col></colgroup><tbody> </tbody> Heatcare Office 2, Enterprise Centre Hill Road Aberdare NP16 7AX 012222222222More information XYZ Plumbing and Electrical Engineers 1 Union Street Cardiff CF11 6ER 0111111111More information Mikes Training somewhere Drive West somewhere Aberdeen AB88 3AL 011119991392/07717704444More information <colgroup><col><col><col><col><col><col></colgroup><tbody> </tbody>

<colgroup><col></colgroup><tbody>
</tbody>

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