Copy value and paste to multiple cells

[Nigel Wroe]

I have a 50,000 lines worksheet listing Yellow Pages type business names and
numbers.

The business date is always three lines. Each (group of) businesses are
listed down th epage under a category for that group/business.

Like so:

FUNERAL DIRECTORS
Farnham Funeral Service 01252 711444
100 Shortheath Rd
Farnham, Surrey GU98SE
GARAGE SERVICES
>Farnborough Volkswagen Centre 01252 521152
10 Farnborough Rd
Farnborough, Hampshire GU146AY
>Farnham Mobile Servicing 01252 715798
6 The Street
Farnham, Surrey GU104PR
GLASS MERCHANTS
Farnham Glass Co 01252 725906
Vine Works/West St
Farnham, Surrey GU97DX

The business categories are capitalised here for ease of identification, and
for example in the GARAGE SERVICES category, used in thi smail, the ">" to
denote the start of the new business. Neither Capitals nor > exists in the
real data, although the category is in a shaded cell.

The data is held in two colums, A, B, with the business category in a merged
A-cell.

What I am trying to do is get each business listed on a single row, together
with its category so that I can import into an access database. As the
number of businesses in the listing varies for each category, I have
evaluated the category by a simple formula in column C, then intend to fill
the gaps between each categry appearing un column C, down th epage with the
value of the populated cell immediately next above. I coul dand did use
something like this in lotus years ago, but the excel learn routine will not
evaluate lotus type navigation, so I am stuck.

My stab at the macro learn using point and click is below.

Sub Macro1()
'
' Macro1 Macro
' Macro recorded 30/12/1999 by Nigel Wroe
'
' Keyboard Shortcut: Ctrl+q
'
Selection.End(xlDown).Select
Selection.Copy
Range("D128").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=
_
False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Selection.End(xlDown).Select
Selection.End(xlUp).Select
Range("D129").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=
_
False, Transpose:=False
End Sub

As you can see, I can't get the range to be anything other than the
"learned" range.

I am quite content to hotkey a few thousand times to get the job done.

Any Millenium Macro Masters out there with a solution? You can tell I am a
novice at this VBA stuff.

Thanks for any help proffered.

Nigel

[Tom Ogilvy]

This macro assumes your business directory sheet is named DATA and you have
a second blank sheet named DATA1

I am not sure what is in column B for each entry, but the macro puts column
A entries in B,C,D and Column B entries in E,F,G
It should be fairly obvious how to rearrange that.

The macro recognizes Business categories by testing for merged cells (you
said only the categories were merged cells).

Copy this code and paste it into the same module as your recorded macro.

Change the names of the sheets to ones which reflect your situation. Then
go back to excel and run the BuildData macro.

Make sure you do all this on a copy of the workbook so if there is a problem
it does not damage your data.

Sub BuildData()
Dim rng As Range
Dim cell As Range

With Worksheets("Data")
Set rng = .Range("A1").CurrentRegion.Columns(1)
End With
rw = 1
i = 1
While i < rng.Rows.Count
Set cell = rng.Cells(i)
If cell.MergeCells Then
bCat = cell.Value
i = i + 1
Else
With Worksheets("Data1")
.Cells(rw, "A").Value = bCat
.Cells(rw, "B").Value = cell(1, 1).Value
.Cells(rw, "C").Value = cell(2, 1).Value
.Cells(rw, "D").Value = cell(3, 1).Value
.Cells(rw, "E").Value = cell(1, 2).Value
.Cells(rw, "F").Value = cell(2, 2).Value
.Cells(rw, "G").Value = cell(3, 2).Value
rw = rw + 1
i = i + 3
End With
End If
Wend
End Sub

HTH,
Tom Ogilvy
MVP Excel

Nigel Wroe <nw...@wroenco.com> wrote in message
news:84h2r7$srg$1...@uranium.btinternet.com...

[Fabien Turcotte]

Nigel,

If your worksheet contains TITLES in UPPERCASE (like FUNERAL DIRECTORS,
etc.), perhaps you would like to get rid of this information. This(>>),
added to Tom's answer will complete the job.

Sub BuildData()
Dim rng As Range
Dim cell As Range

With Worksheets("Data")
Set rng = .Range("A1").CurrentRegion.Columns(1)
End With

>>Do Until ActiveCell.Offset(1, 0).Value = ""
>> If ActiveCell.Value = UCase(ActiveCell.Value) Then
>> ActiveCell.EntireRow.Delete
>> End If
>> ActiveCell.Offset(1, 0).Select
>>Loop