格納だけならsetで簡単にできる
しかし他のセルにこれを適用しようとするとフリーズ。理由は知らん

割りと真面目に
＞Copy Destinationで別のシートに格納
したほうがいい気がする

Sub foo()
'A1の一文字目のフォント情報をB1二文字目に
Set bar = Cells(1, 1).Characters(Start:=1, Length:=1).Font
Cells(1, 2).Characters(Start:=2, Length:=1).Font = bar
End Sub