VBAについてどなたかご教授お願いいたします

どなたかご教授いただければ幸いです。

エクセルファイルAの4行目の値全てを、デスクトップ上 エクセルファイルBの最終行に
値貼りつけしたいのですが、うまく動作しません。
一旦、下記コードのようにエクセルファイル4行目の値を値貼りつけしてから実行するとうまくいきました。
ただ、転記したいファイルAの4行目には関数を入れているため、できれば関数はそのまま残したいのでエラー保護含め改善策をお教えいただければ幸いです。

※補足
　ファイルBにはデータを集めていきますので、最終行を取得して保存しております。
Sub 管理_保存()
Set WSH = Create Object("Wscript .Shell")
''Dim Desktop Path As String
Desktop Path = WSH .SpecialFolders("Desktop")
Application .Screen Updating = False ''画面停止
str Msg = "個人管理表に追加しますか？"
int Ret = Msg Box(str Msg, vb Yes No, "Msg Box")
If int Ret = vb No Then Exit Sub
Sheets("ファイルA").Select
Range("A4:T4").Select
Application .Cut Copy Mode = False
Selection .Copy
Selection .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone , SkipBlanks _
:=False, Transpose:=False
Rows("4:4").Select
Selection .Copy
Range("A1").Select
Workbooks .Open Filename:= Desktop Path & "\管理\ファイルB.xlsx"

n = Cells(Rows .Count, "A").End(xlUp).Row + 1
Range("A" & n).Select

ActiveSheet .Paste
Cells .Select
Application .CutCopyMode = False
Selection .Copy
Selection .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone , SkipBlanks _
:=False, Transpose:=False
ActiveWorkbook .Save
ActiveWindow .Close

Application . ScreenUpdating = True ''画面再開

Set WSH = Nothing

End Sub

No.3 回答者： fujillin 回答日時： 2021/04/10 14:42

こんにちは

＞できれば関数はそのまま残したいので
元の関数を消さなくても、Value = Value 形式で値だけ転記するか、またはCopyして「値をペースト」すれば、関数はそのままでも目的を達することができるのではないでしょうか？

ざっと見ただけですが、以下気になる点をいくつか。
・変数名やメソッドに不可思議な空白がありますが、そのままで動作しているのでしょうか？
・「ファイルB」のシートを指定していませんが、シートは1つしかないのでしょうか？
・「ファイルB」の最終行はA列で判断しても問題ないのでしょうか？
　（値を転記した際に空白があると、次には上書きされてしまう）

など不明点が多いですが、ひとまず、ご提示と同等の内容を簡略なコードで実現できると思われるものをご参考までに。
（最初の、確認メッセージ等は省略しています）

※ 値のみの転記なので、書式等はコピーされません。

Sub sample_12302020()
Dim col, dat, path

col = ActiveSheet.UsedRange.SpecialCells(xlLastCell).Column
dat = Cells(4, 1).Resize(, col).Value

path = CreateObject("Wscript.Shell").specialfolders("Desktop")
With Workbooks.Open(path & "\管理\ファイルB.xlsx")
Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, col).Value = dat
.Close True
End With

End Sub

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2021/04/10 14:21

こんにちは、

先の回答部分は変更されていないのですね。
OKです。
処理の流れは同じで考えて書き直してしまいますが、悪く思わないでくださいね。
内容は、ご確認ください。
処理の解釈が違っていれば、補足に上げてください。
出来れば、解決されるまで、締め切らないように希望します。

Sub 管理_保存()
Dim 個人管理表 As String
Dim n As Long
個人管理表 = CreateObject("Wscript.Shell").SpecialFolders("Desktop") & _
"\管理\ファイルB.xlsx"
If MsgBox("個人管理表に追加しますか？", vbYesNo, "実行確認") = vbNo Then Exit Sub
Application.ScreenUpdating = False ''画面停止
Sheets("ファイルA").Rows("4:4").Copy
If Dir(個人管理表) <> "" Then
On Error Resume Next
Open 個人管理表 For Append As #1
Close #1
If Err.Number > 0 Then
On Error GoTo 0
Windows("ファイルB.xlsx").Activate
'どこのシートか分からないので取り敢えず一番左のシート（変更して）
Sheets(1).Activate　
With ActiveSheet
n = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & n).PasteSpecial Paste:=xlPasteValues
.Range("A1").Select
End With
ActiveWorkbook.Close SaveChanges:=True
Else
Workbooks.Open Filename:=個人管理表
'どこのシートか分からないので取り敢えず一番左のシート（変更して）
Sheets(1).Activate
With ActiveSheet
n = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & n).PasteSpecial Paste:=xlPasteValues
.Range("A1").Select
End With
ActiveWorkbook.Close SaveChanges:=True
End If
Else
MsgBox 個人管理表 & vbCrLf & _
"が存在しません"
End If
Application.CutCopyMode = False
Range("A1").Select
Application.ScreenUpdating = True ''画面再開
End Sub

この回答へのお礼

ご回答ありがとうございます。
事細かにご説明ありがとうございます。
コードまでありがとうございます。
追加で質問ですが、
異なるＰＣでも同じ動作にしたいのですが（違う人が使用しても）

　≫個人管理表 = CreateObject("Wscript.Shell").SpecialFolders("Deskto　p") & _
"\管理\ファイルB.xlsx"

上記は動作しますでしょうか？

お礼日時：2021/04/10 14:43

No.1 回答者： ママチャリ 回答日時： 2021/04/10 13:04

＞一旦、下記コードのようにエクセルファイル4行目の値を値貼りつけしてから実行するとうまくいきました。

回答で無くて申し訳ないのですが・・・。

提示されているものは、うまくいった方のコードですよね？
改善策を教えて欲しいのであれば、うまくいかない方のコードを提示した方が良いと思いますよ。
できれば、どう上手くいかないのかも書いてください。

この回答へのお礼

ご回答ありがとうございます。
おっしゃる通りですね。
うまくいかないほうを消してしまったので、動作する方でもお詳しい方は
分かるかなと考えておりました。
今後は参考にさせていただきます。

お礼日時：2021/04/10 13:22