VBA - Copy formatting from linked cell

[timpa]

Hi All,

I've searched all over the internet and not found an answer.
I need a macro which will read the cell I have linked to, copy the formatting and paste it into the current cell.

All cells in the sheet will be linked to another source.
Each cell in the source is linked from multiple cells in the destination sheets.

What I have so far is this.

Sub CopyFormat()
        If TypeName(Selection) <> "Range" Then Exit Sub
    On Error Resume Next
'   Check the cells with formulas
    For Each cell In Selection.SpecialCells(xlFormulas, 23)
        
        ActiveCell.PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
    Next cell
End Sub

As you can see it reads through a selected range and is all ready to paste.
All I'm missing is the code to read the cell it is linked to and copy it.

Anyone able to assist?

 

[mikerickson]

If you want the formatting of precedent cells to be transfered to the dependent cells, you may want this, which finds all the precedents of a cell.
http://www.vbaexpress.com/forum/showthread.php?t=19348&page=2&highlight=navigate
As indicated in that thread, finding precedents that are not on the same sheet is not a trivial problem.

For precedents on the same sheet, the .Precedents property can be used.

Dim formulaCell As Range
Dim feederCell As Range
For Each formulaCell In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas)
    With formulaCell
        On Error Resume Next
        Set feederCell = .Precedents.Item(1)
        On Error GoTo 0
        If Not (feederCell Is Nothing) Then
            feederCell.Copy
            .PasteSpecial xlFormats
        End If
    End With
Next formulaCell

 

[timpa]

Thanks for the answer, unfortunately it will be coming from other sheets

 

[mikerickson]

Since .NavigateArrows selects the precedent cells, this is fairly slow, but it should get the job done.

Sub ColorFromPrecedents()
    Dim currentSel As Range, oneCell As Range
    Set currentSel = Selection
    On Error GoTo HaltRoutine
    Application.ScreenUpdating = False
    
    For Each oneCell In currentSel.Parent.Cells.SpecialCells(xlCellTypeFormulas)
        With oneCell
            .ShowPrecedents
            .NavigateArrow True, 1, 1
            ActiveCell.Copy
            .PasteSpecial xlFormats
        End With
    Next oneCell
    
    With currentSel.Parent
        .Activate
        .ClearArrows
    End With
    currentSel.Select
    
HaltRoutine:
    Application.ScreenUpdating = True
    On Error GoTo 0
End Sub

 

[timpa]

That is absolutely perfect.
If you can PM me an email address I'd love to paypal you something next week.
Always appreciative of people giving help, especially when you expected no reward.

 

[mikerickson]

Thanks for the offer, but the advise given in this forum is free for all.
If you feel obligated, put a little extra in the collection plate next Sunday. Or help someone else with an Excel issue.