VBAコピーのフォント

VBAで値をシート間でコピーするコードを書きました。

コピー元　メイリオ
コピー先　ＭＳＰゴシック
とフォントが変わってしまします。

コピー先シートのフォントはメイリオにしてあります。
コピー後もフォントをメイリオにするにはどうすればよいでしょうか。

ちなみにエクセルオプションの規定フォントもメイリオにしています。

よろしくお願いいたします。

vba
1Sub 機材管理()
2
3Dim sh1, sh2, sh3 As Worksheet
4Dim i, j, lrow, mrow, mrow3 As Long
5
6
7Set sh1 = Worksheets("全品目")
8
9Set sh2 = Worksheets("使用中")
10    mrow = sh2.Cells(Rows.Count, "B").End(xlUp).Row
11    sh2.Range("B2:K" & mrow + 1).Clear
12    
13Set sh3 = Worksheets("返却済")
14    mrow3 = sh3.Cells(Rows.Count, "B").End(xlUp).Row
15    sh3.Range("B2:K" & mrow3 + 1).Clear
16
17    lrow = sh1.Cells(Rows.Count, "B").End(xlUp).Row
18    mrow = 3
19    mrow3 = 3
20 
21    For i = 3 To lrow
22        
23        If sh1.Cells(i, "K").Value = "使用中" Then
24        sh2.Range("B" & mrow & ":J" & mrow).Value = sh1.Range("B" & i & ":J" & i).Value
25        mrow = mrow + 1
26        
27        ElseIf sh1.Cells(i, "K").Value = "返却済" Then
28        sh3.Range("B" & mrow3 & ":Ｉ" & mrow3).Value = sh1.Range("B" & i & ":I" & i).Value
29        mrow3 = mrow3 + 1
30        
31        End If
32    Next i
33       
34        
35End Sub
36
37

行動規範の内容に同意します

回答2件

ベストアンサー

ClearをClearContentsにしてみてください。
Clearは書式もクリアしてしまいます。
規定フォントをメイリオにしているのに発生するのは謎ですが。。。

投稿2020/07/29 07:43

ttyp03

総合スコア16998

tanetanetane

2020/07/29 07:50

clearcontnsに変えたところできました！ありがとうございます！

radames1000

2020/07/30 00:24

規定フォントがMSPゴシックの時に作られたファイルであれば、この事象が発生します。

行動規範の内容に同意します

＞ちなみにエクセルオプションの規定フォントもメイリオにしています。
エクセルのオプションの設定は、複数ブックを開いた時には、
最初に開いたブックのオプションの設定に依存します。
なので、「オプションの設定を変えているはず。」と思っていても、
ファイルを開く順番でオプションの設定が変わっていることは、
よくあります。

今回の件の場合、
コピー元のフォントの情報などのも一切合切コピーしてしまえばいいと思うので、
敢えて、Range.Value = Range.Value　と、
「セルの値のみ」を転記するのではなく、
「セルそのもの」をコピペした方がよいのではないでしょうか？

また、
「全品目」シートのデータを更新後、
「使用中」または「返済済み」シートを
選択・表示したときに、リンクして内容が更新されていたらいいと思うので、
それらのシートが「アクティブになったとき」に、
必要な情報を表示してはいかがでしょうか。
元のデータを更新しなくても、
シートを切り替えるたびにマクロが起動することになりますが、
そうすることで、
パソコンにそれほど負担をかけることなく、
ユーザーにマクロの存在を意識させることなく、
リアルタイムに情報が更新されているように見せることが可能かと思います。

以下、thisworkbookモジュールに記入します。

ExcelVBA
1Private Sub Workbook_SheetActivate(ByVal Sh As Object)
2    If Sh.Name = "全商品" Then Exit Sub
3    Sh.UsedRange.Clear
4    With Me.Worksheets("全商品").UsedRange.Offset(2)
5        .AutoFilter Field:=11, Criteria1:=Sh.Name
6        .Copy Sh.Cells(1)
7        .AutoFilter
8    End With
9End Sub