Solved: Paste Formats from Above

[danesrood]

Dear All

This might sound a bit bizarre or down right lazy but I constantly have to copy data in from other sources and then using the paste format brush paste down the format from the cell/s above.

Is it possible to create some code that I could attach to some keystrokes say Shift Control F in the personal.xls file that would enable me to do this. This could be for either a single cell or a range of cells.

Here's hoping.

Steve

[mancubus]

hi.
just select the cell(s) to be formatted and then run the macro below.
you can assign it to a button or shape in the worksheet.


Sub CopyAboveFormat

With Selection
.Offset(-1, 0).Copy
.PasteSpecial Paste:=xlPasteFormats
End With

End Sub

[danesrood]

mancubus

Great that works a treat.

Thank you so much, you wouldn't believe the number of times I have to move the mouse to that paint brush which is a pain as I'm more of a keyboard person.

Grateful thanks from England.

Right off to bed.


zzzzzz zzzzz

[mancubus]

you're wellcome.

glad it helped.

pls mark the thread as solved from thread tools.

[danesrood]

Mancubus

Not sure if you will see this but a slight variation has cropped up where in addition to pasting the format from above I now need to change the case to Proper as everything is now coming in as all Upper case.

As ever my grateful thanks

[mancubus]

danesrood

ConvertCase procedure converts the first letter of every word in cells in selection to uppercase.

if only one cell is selected then expands the selection to active worksheet's used range.

if you want proper case only in selection, then delete all lines but Set rAcells = Selection in the following bit from the procedure.

If Selection.Cells.Count = 1 Then
Set rAcells = ActiveSheet.UsedRange
Else
Set rAcells = Selection
End If



Sub ConvertCase()
'http://www.ozgrid.com/VBA/change-case-text.htm

Dim rAcells As Range, rLoopCells As Range
Dim lReply As Long

'Set variable to needed cells
If Selection.Cells.Count = 1 Then
Set rAcells = ActiveSheet.UsedRange
Else
Set rAcells = Selection
End If

On Error Resume Next 'In case of NO text constants.

'Set variable to all text constants
Set rAcells = rAcells.SpecialCells(xlCellTypeConstants, xlTextValues)

If rAcells Is Nothing Then
MsgBox "Could not find any text."
On Error GoTo 0
Exit Sub
End If

lReply = MsgBox("Select 'Yes' for UPPER CASE or 'No' for Proper Case.", _
vbYesNoCancel, "OzGrid.com")

If lReply = vbCancel Then Exit Sub
If lReply = vbYes Then ' Convert to Upper Case
For Each rLoopCells In rAcells
rLoopCells = StrConv(rLoopCells, vbUpperCase)
Next rLoopCells
Else ' Convert to Proper Case
For Each rLoopCells In rAcells
rLoopCells = StrConv(rLoopCells, vbProperCase)
Next rLoopCells
End If

End Sub

[danesrood]

mancubus
Sorry for delay in getting back to you.
Works a treat. Thank you very much again

[mancubus]

you're wellcome.


PS: credits must be given to OzGrid.