シートを別ブックに、名前を変更して保存

投稿者 : arex     投稿日時 : 2024/06/18(Tue) 19:42:06     OS : 未指定     EXCEL : 未指定

---

連続の質問すいません。先ほど別の質問させていただいたものです。
同じように下記コードを活用しております。

'Dir関数を使ってフォルダ内のファイル一覧表示
Sub ファイル名取得()

    Range("A2:A1000").ClearContents

    Dim fname As String
    Dim myPath As String
    
    myPath = Range("A1")
    If myPath = "" Then Exit Sub
    
    fname = Dir(myPath & "\*.xls*") 'ファイルの種類を指定
    
    Dim cnt As Long
    cnt = 3
    
    Do While fname <> ""
            Debug.Print fname   'ファイル名のみ取り出せる
            Cells(cnt, "A") = fname
            cnt = cnt + 1
        fname = Dir()
    Loop

End Sub

こちらのコードで開いたブックに、別ブックで開いているシートをコピー保存し、シート名を入力（もしくは決まられた名前）し保存まですることは可能でしょうか？
（例）仮ブックの仮シートを→コードで開いたブックの最後尾に、コピーし→シート名を本シートに変更する
すいません、こちらもお手すきの際にご教授いただけますと大変うれしく思います。
よろしくお願いいたします。

投稿者 : さんこう     投稿日時 : 2024/06/18(Tue) 22:37:55

---

回答ではありません。

＞こちらのコードで開いたブックに、

このコードでブックが開かれるようには見えませんが、
凡人には理解不能な特殊技術が使われているのでしょう。


＞別ブックで開いているシートをコピー保存し、

「別ブック」とは、何でしょうか？

「コピー保存」とは、どんな操作ですか？


＞シート名を入力（もしくは決まられた名前）し

誰が入力するのですか？

投稿者 : どうかしてるぜ     投稿日時 : 2024/06/19(Wed) 09:31:57

---

■[返信 1] さんこうさん（2024-06-18 22:37:55）の記事
＞ 回答ではありません。
＞
＞ ＞こちらのコードで開いたブックに、
＞
＞ このコードでブックが開かれるようには見えませんが、
＞ 凡人には理解不能な特殊技術が使われているのでしょう。
＞
＞
＞ ＞別ブックで開いているシートをコピー保存し、
＞
＞ 「別ブック」とは、何でしょうか？
＞
＞ 「コピー保存」とは、どんな操作ですか？
＞
＞
＞ ＞シート名を入力（もしくは決まられた名前）し
＞
＞ 誰が入力するのですか？
＞
＞

相変わらず、イヤミな投稿。
意地悪なところがメチャメチャ発揮されている。

＞開いたブックに、別ブックで開いているシートをコピー保存し・・・
というのを上のコードに追加したいけど、どうしたらいいでしょうか？
っていう質問じゃん。

この陰険さは凡人には理解不能な特殊技能。

投稿者 : arex     投稿日時 : 2024/06/19(Wed) 12:21:17

---

どうかしてるぜ様。
ありがとうございます。

投稿者 : tkit     投稿日時 : 2024/06/19(Wed) 14:04:50

---

■[返信 2] どうかしてるぜさん（2024-06-19 09:31:57）の記事
＞
＞ 相変わらず、イヤミな投稿。
＞ 意地悪なところがメチャメチャ発揮されている。
＞
＞ ＞開いたブックに、別ブックで開いているシートをコピー保存し・・・
＞ というのを上のコードに追加したいけど、どうしたらいいでしょうか？
＞ っていう質問じゃん。
＞
＞ この陰険さは凡人には理解不能な特殊技能。
＞

さんこうさんの質問内容に対する指摘は、真っ当だと思いますよ。
質問内容を忖度して理解出来たなら、コードを提示されては。

＞ こちらのコードで開いたブックに、別ブックで開いているシートをコピー保存し、シート名を入力（もしくは決まられた名前）し保存まですることは可能でしょうか？
に対する私の回答は、「不可能」です。

投稿者 : arex     投稿日時 : 2024/06/19(Wed) 16:10:16

---

tkit様。
申し訳ありません。ありがとうございます。

投稿者 : tkit     投稿日時 : 2024/06/19(Wed) 16:32:06

---

アドバイスとして、
自身でコーディング出来ないのであれば何でも１つにせず、
各々個別の機能として使用した方が汎用性が上がりますよ。


＞ （例）仮ブックの仮シートを→コードで開いたブックの最後尾に、コピーし→シート名を本シートに変更する

上記をサンプルで作りました。
マクロブックやシートの情報が無いので、アクティブシートとなっています。
A列のファイル名を選択(複数可)して実行してください。
意に沿わない結果だったとしても、責任は取れませんので。

Sub sample()
    Dim ws As Worksheet
    Set ws = Workbooks("仮ブック.xlsx").Worksheets("仮シート")
    
    Dim rng As Range, cel As Range
    Set rng = Selection
    For Each cel In rng
        Dim wb As Workbook
        Set wb = Workbooks.Open(Range("A1") & "\" & cel.Value)
        ws.Copy After:=wb.Worksheets(Worksheets.Count)
        wb.Worksheets(Worksheets.Count).Name = "本シート"
        wb.Save
        wb.Close
    Next
End Sub

投稿者 : ピロリ     投稿日時 : 2024/06/21(Fri) 09:15:42

---

質問者さんからの返答がないですが、解決されたのでしょうか？

ご提示されたコード（指定フォルダ「A1セル」内の全ブックの名称を抽出する「A3セル～」処理）をベースに、
＞ 　･･･ 別ブックで開いているシートをコピー保存し、シート名を入力（もしくは決まられた名前）し保存 ･･･
＞ （例）仮ブックの仮シートを→コードで開いたブックの最後尾に、コピーし→シート名を本シートに変更する
処理を追加ってことは、下のようなことがしたいってことですかね？（ かなり 忖度してますけど･･･ ）
『 指定フォルダ（A1セルに入力のパス）内の全ブックに対し、表示中の「仮ブック.xlsx」の「仮シート」を
　 最後尾へコピー（追加）。コピーしたシートは予め入力したシート名（「本シート」とか）へ変更する。
　 処理したブック名は A3セルから下へ記録する。 』
私なりの解釈なので、外していたら読み捨てて下さい。

余談ですが、シートの追加って、同じ名称のシートは追加できない訳で、同一名のシートが存在した場合の処置が
ネックになると思います。下のコードは一旦削除してから追加する（結果的に上書きみたいな）処理にしてます。
もしかしたら、この辺（32～36step目）は参考になるかも？

Sub 全ブックへシートをコピー()
    Dim myPath As String
    myPath = Range("A1")
    If myPath = "" Then Exit Sub
    
    Dim wb1 As Workbook, ws1 As Worksheet
    On Error Resume Next
    Set wb1 = Workbooks("仮ブック.xlsx")
    If Err.Number <> 0 Then                                     '｢仮ブック.xlsx｣が無いとか
        MsgBox "「仮ブック.xlsx」を開いて！"
        Exit Sub
    End If
    Set ws1 = wb1.Worksheets("仮シート")
    If Err.Number <> 0 Then                                     '｢仮シート｣が無いとか
        MsgBox "「仮シート」が見当たらない！"
        Exit Sub
    End If
    On Error GoTo 0
    
    Dim wb2 As Workbook, ws2 As String
    ws2 = InputBox("シートの名称は？", , "本シート")            '追加するシート名称を入力
    If ws2 = "" Then Exit Sub
    'ws2 = "本シート"                                           'もしくは、決められた名称
    
    Dim fname As String, cnt As Long
    Range("A2:A1000").ClearContents             ' ← 3行目からのクリアでなくて問題ないの？
    cnt = 3
    fname = Dir(myPath & "\*.xls*")
    Do While fname <> ""
        If fname <> ThisWorkbook.Name And fname <> "仮ブック.xlsx" Then 'この2ブックは除外
            Set wb2 = Workbooks.Open(myPath & "\" & fname)      'ブックを開いて
            Application.DisplayAlerts = False                   '問合せを非表示
            On Error Resume Next
            wb2.Worksheets(ws2).Delete                          '｢本シート｣は一旦削除
            On Error GoTo 0
            Application.DisplayAlerts = True                    '問合せの非表示を解除
            ws1.Copy After:=wb2.Worksheets(Worksheets.Count)    '｢仮シート｣をコピーし
            wb2.Worksheets(Worksheets.Count).Name = ws2         '｢本シート｣へ名称変更
            wb2.Save                                            '上書き保存して
            wb2.Close                                           '閉じる
            
            Cells(cnt, "A") = fname                             '処理済のブック名を記録
            cnt = cnt + 1
        End If
        fname = Dir()                                           '次のブックを取得
    Loop
End Sub