VBA 指定先へのコピペと新規保存

質問

いつも参考にさせて頂いています。
今回もどなたかのお知恵が借りれる事を祈っております。

Aというファイルに入力されているデータのレイアウトは1行に1案件となっており、
列AからB、C、・・・と報告に必要な項目が並んでいます。
これを各行（＝各案件）ごとに専用のファイル（Bファイル）に転写、別名で保存しています。因みにBファイルはAのファイルとはレイアウトが全く異なり、単純に行全体のコピペ～保存という訳にはいかなくて困っています。

■Aファイルのレイアウト
1 A　　 B　　　C　　　D　　　E　　　F　　　G　　　H　　　I　　　L　 M
2 No 受付　日付　　担当　起票日　起票者　所属　　区分　　内容　回答日 回答者　　
3 1 1111 5/21 MKG 5/31 FSS 1-1 VDA gaga 6/3 GHQ
4 2 1321 5/22 FSB 6/11 CTU 3-1 NCA HAH 6/20 GHQ

データはB列からO列まで入力されていますが、JとKの情報はコピー不要です。
また行数（＝案件数）は一定ではなく、何行目までデータが入っているか決まっていません。

■Bファイルへのペースト先（指定したセルにデータが入っている場合は上書き）
AファイルのB列のデータ・・・J5
AファイルのC列のデータ・・・H2
AファイルのD列のデータ・・・D3
AファイルのE列のデータ・・・D7
AファイルのF列のデータ・・・F7
AファイルのG列のデータ・・・I7
AファイルのH列のデータ・・・D8
AファイルのI列のデータ・・・C10
AファイルのL列のデータ・・・D19
AファイルのM列のデータ・・・F19
AファイルのN列のデータ・・・C22

■コピペ後の処理（コピペしたBファイルの別名保存）
BファイルのJ5に貼付けたデータをそのままファイル名としてローカルのデスクトップに保存します。

以上です。
お知恵を貸して下さい！

回答No.7

merlionXX · ベストアンサー

masurao200さんも苦労しているようですね。

> 頂いた内容を実行してみると、デスクトップと表示された窓がピコっと出てきます。

デスクトップのパスがちゃんと返ったということですね？

> これを実行するとファイルが生成され最後に実行エラーが出て、Book●●がポツンと存在しています。
> そのままデバッグを押してみると↓の一文が黄色く塗られていました。

わたしも、あなたの掲示したコードをそのままコピペして試してみましたが、ちゃんとデスクトップに複数のBOOK生成されました。
masurao200さんもファイルが生成されデスクトップに保存されているけど、最後にひっかかっちゃうということですね？
こちらではあなたのファイルやパソコンを見ることができないので想像するしかありません。

CreateObject("WScript.Shell").SpecialFolders("Desktop") で取得したパスに続く　& "\" & ws(1).Range("E3").Value　でファイル名を設定しています。

これらの状況から考えられるのは、エラーになったとき、BファイルのSheet1のE3セルの値が、ファイル名に使えない文字（\/:*?"<>|など）を含んでいるのではないでしょうか？
あるいはひょっとしてすでにデスクトップに存在するファイル名だったとか？
確認してみてください。
あと、AファイルのA列にはデータ数だけNoがふってありますね？
そうでないとデータの数だけファイルが作られませんので。

お礼

merlionXX様

いつも本当にありがとうございます。
お蔭様でエラーなく完了することができました。

>あと、AファイルのA列にはデータ数だけNoがふってありますね？
>そうでないとデータの数だけファイルが作られませんので。

実はこの部分を読ませていただき、急いでAファイルを見てみたところ、通しNoが100まで振ってあり、案件が記載してある行は30番までという状況でした。
慌てて31番～100番を消して再度実行してみたところ、エラーなく複製もきちんとコピーされていました。

私の未熟な質問のせいでお手数をかけ、ただただ感謝です。

質問の仕方、マナー、本件以外にも色々と勉強をさせて頂きました。

本当にありがとうございました。

回答No.9

merlionXX

> 通しNoが100まで振ってあり、案件が記載してある行は30番までという状況でした。

原因はこれでしたね。
Noとデータ数が常に一致すると限らないなら、Noの列をマクロでは見ないようにしたほうが良かったですね。
そこまで気が回らなかったわたしの落ち度です。反省
(^^;;

B列の「受付」ならデータ数が常に一致するのであれば、cj_moverさまがおっしゃるように
For n = 3 To ws(0).Cells(Rows.Count, "B").End(xlUp).Row
と、B列見るように変えてください。

cj_moverさま、お久しぶりです。
merlionXXはいつまでも未熟で困ったものです。
┐(´∇｀)┌

回答No.8

cj_mover

Re

ん？
Ａファイルで主キーにあたるものはＢ列にある"受付"なのですから
　回答No.1の記述で
　　For n = 2 To ws(0).Cells(Rows.Count, "A").End(xlUp).Row
　の "A" を "B" に正したら案外呆気なく通る
というのが可能性高い気がします。
具体的なデータを見てないので確率的な話ですが試す価値はあるかと。

回答No.6

cj_mover

お邪魔します。

No.1へのお礼に
＞A、BどちらもデスクトップにA、Bという名前で保存しています。
とありますから、デスクトップのパス取得に拘らずに
ThisWorkbook.Pathでフォルダを取得する方が後々楽かも知れません。
もっとも、私は、デスクトップにはショートカットしか保存しない主義ですし、
いずれ、どこかのフォルダに格納しなければならない訳ですから、
一時的にであっても、デスクトップにファイル保存するようなプログラムは好みません。
Ａファイル、Ｂファイル、新規に作成するファイル、皆、同一のフォルダに置く
という条件で解釈換えをしてみました。（むしろ一般的な処理です）
同一のフォルダ＝デスクトップ、という条件でも当然動きます。

merlionXX さんは結合セルのエキスパートですから、
結合セルが原因で動かないようなものを書くことは滅多にないと思います。
今回、質問者さんが途中から結合セルがエラーの原因と考えて
（そういう疑問を持つことや尋ねることは、寧ろポジティブなことですが）
原質問とは全く異なる（転記するデータの数まで変わってしまう）条件変えをしたのは、
ちょっと勇み足かな、と思います。
回答者としては、継続的なレスポンスが難しくなってしまうのではないでしょうか。
→私が書くのはあくまで、No.5へのお礼が記される前までの情報から類推されるニーズ
に応えるものです。

ところで、
　ファイルＡのデータは、
　　直に値を入力したものですか？
　　　それとも他のファイルから取り込んだ（orコピーした）ものですか？
　　　或いは、数式で他のデータを参照したものでしょうか？
　　空白セルや空行はありますか？
なるべく、こういう情報も盛り込むように質問すると、返ってくる内容が充実することが多いです。
（回答者が確認すれば済む、というのも一理、、、）
→Ｂ列が空白の場合は転記も新規作成もしないように書きました。
Excelだけでなく表計算ソフト一般にいえる事ですが、
　3-1
のような値は（ＶＢＡとは関係なく）結構脆弱です。
文字列として扱うのに、セルの書式設定で文字列を指定することは勿論ですが、
データとして堅牢なものにする為には先頭にプレフィックス「'」を付けた方が確実です。
私は他の表記に換えることが多いですけれど、避けられない場合は
必ず入力（or取り込み）の段階でプレフィックスを付けるようにしています。
→ＡファイルのＧ列にプレフィックスを付加するように書いてます。
→そうしたくない場合は◆マークした行を削除してください。
また、Ｂファイルの転記先のうち、H2,D7,D19については
事前に適切な書式設定（日付）が済んでいるか確認してください。

どちらかというと確認のために書いたコードです。
レスポンスがあれば（日を置いてもよければ）また対応しますが、
本心はmerlionXX さんの手で解決されることを望んでいます。
とりあえず、動作確認をお願いします。

Sub Records2ReportsCrNewBk() ' okg6925811
　Dim vKey As Variant
　Dim wbkRepo As Workbook ' ファイルＢブック
　Dim shTbl As Worksheet ' ファイルＡシート
　Dim rngTbl As Range ' 元データ（ファイルＡ）のセル範囲
　Dim rngRepo As Range ' レポート出力先（ファイルＢ）のセル範囲
　Dim r As Range ' ループ用
　Dim sNrwNmTmpl As String '新規レポートブックのフルネーム雛型
　Dim sNewNm As String ' 新規レポートブックのフルネーム
　Dim nBtmRow As Long ' 元データのデータ最下行
　Dim i As Long, j As Long ' ループ用
　With ThisWorkbook
　　Set shTbl = .Sheets("Sheet1")
　　sNrwNmTmpl = .Path & "\?.xls"
　　nBtmRow = shTbl.Cells(Rows.Count, 2).End(xlUp).Row
　　Set rngTbl = shTbl.Range("B:N")
　End With
　On Error GoTo OpenTmpl_
　Set wbkRepo = Workbooks("B.xls")
　On Error GoTo 0
　Set rngRepo = wbkRepo.Sheets("Sheet1").Range("J5,H2,D3,D7,F7,I7,D8,C10,D19,F19,C22")
　For i = 2 To nBtmRow
　　With rngTbl.Rows(i)
　　　vKey = .Cells(1).Value
　　　If vKey <> "" Then
　　　　j = 0
　　　　For Each r In rngRepo.Areas
　　　　　j = j + 1
　　　　　Select Case j
　　　　　　Case 6: .Cells(j).Value = "'" & .Cells(j).Value ' ◆
　　　　　　Case 9: j = 11
　　　　　End Select
　　　　　r.Value = .Cells(j).Value
　　　　Next r
　　　　sNewNm = Replace$(sNrwNmTmpl, "?", vKey)
　　　　wbkRepo.SaveAs sNewNm
　　　End If
　　End With
　Next i
'　wbkRepo.Close False
Exit_:
　Set wbkRepo = Nothing: Set shTbl = Nothing: Set rngTbl = Nothing: Set rngRepo = Nothing
　Exit Sub
OpenTmpl_:
　Workbooks.Open ThisWorkbook.Path & "\B.xls"
　Resume
End Sub

お礼

Cj mover様

お礼が遅くなりましたが、本日目的を果たす事ができました。
教えて頂いたコードでも動作確認させて頂きました。無事、動いております。

質問の仕方、マナーの大切さなどこうしたコミュニティを有効に活用するために大事な事も教えて下さり、本当にありがとうございました。

まだまだ知りたい事が沢山あり、これからも使わせて頂くと思いますので、お時間があればまた教えて下さい。

本当にありがとうございました。

回答No.5

merlionXX

ANo4での質問を訂正します。

Sub パス取得()
Dim wb As Workbook
Dim ws(1) As Worksheet
Set wb = Workbooks("B.xls") 'Bファイル指定
Set ws(1) = wb.Sheets("Sheet1") 'Bファイルの転記先シート指定
MsgBox CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ws(1).Range("J5").Value
End Sub

では、どう返りますか？

お礼

merlionXX様

いつもありがとうございます。面倒かけて申し訳ありません。

頂いた内容を実行してみると、デスクトップと表示された窓がピコっと出てきます。
特にエラーは生じませんでした。

また、Bファイルで指定していた転写先のセルのうち、結合されていたものを全て解除してみました。
セル名が変わったので、最初に頂いた構文のセル名を全て書き換えてみたところ、進展がありました。
実行してみると、各案件別のファイルが生成されデスクトップに保存されています。
しかし、最後に実行時エラーが出てきてしまい、ファイル名の付いていないBook●●（←その時々の数字）が生成されたものの何も転写されておらず保存もされなく開いていました。

セル名を書き直したものは↓です。

Sub test01()
Dim wb As Workbook
Dim ws(1) As Worksheet
Dim myW, myX
Dim i As Long, n As Long
Set wb = Workbooks("B.xls") 'Bファイル指定
Set ws(0) = ThisWorkbook.Sheets("Sheet1") 'Aファイルの転記元シート指定
Set ws(1) = wb.Sheets("Sheet1") 'Bファイルの転記先シート指定

myW = Split("B,C,D,E,F,G,I,L,M,N", ",")
myX = Split("E3,E2,C3,C5,E5,E6,B9,C16,E16,B19", ",")

For n = 3 To ws(0).Cells(Rows.Count, "A").End(xlUp).Row
For i = LBound(myW) To UBound(myW)
ws(1).Range(myX(i)).Value = ws(0).Range(myW(i) & n).Value
Next i
ws(1).Copy
ActiveWorkbook.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ws(1).Range("E3").Value
ActiveWindow.Close (False)
Next n

End Sub

これを実行するとファイルが生成され最後に実行エラーが出て、Book●●がポツンと存在しています。
そのままデバッグを押してみると↓の一文が黄色く塗られていました。

ActiveWorkbook.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ws(1).Range("E3").Value

稚拙な表現ですいません。
何とか助けてください。宜しくお願いいたします。

回答No.4

merlionXX

悩ましいですねえ。
マクロはAファイルに書いたのですよね？

Sub デスクトップ取得()
　MsgBox CreateObject("WScript.Shell").SpecialFolders("Desktop")
End Sub

は、正しく表示されるのですね？
では

Sub パス取得()
　Set wb = Workbooks("B.xls") 'Bファイル指定
　Set ws(1) = wb.Sheets("Sheet1") 'Bファイルの転記先シート指定
　MsgBox CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ws(1).Range("J5").Value
End Sub

ならどうなりますか？
（B.xlsを開いたままで試してください）

回答No.3

merlionXX

merlionXXです。

Windows2000でエクセル2000
WindowsXPでエクセル2003
両方で試しましたがエラーになりません。

Sub デスクトップ取得()
　MsgBox CreateObject("WScript.Shell").SpecialFolders("Desktop")
End Sub

で、どう返りますか？
これもエラーならWindowsじゃないのでは？
デスクトップのパスを取得するためにWindows Script Hostを使ったので、Windows環境でなきゃだめなんです。
どうしてもだめなら、
ActiveWorkbook.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ws(1).Range("J5").Value
をあなたのデスクトップのパスをそのまま文字列で指定してみてください。

お礼

merlionXX様

ご回答ありがとうございます。
当方環境もWinXP＆EXCEL 2003です。

頂いたデスクトップ取得については問題なく、ポップアップの画面が掲示されます・
しかし下記ご提供いただいたもので試しますと、同じエラーができます。

ActiveWorkbook.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ws(1).Range("J5").Value

エラーの内容は上記の全文が黄色くセル反転されます。
動作を見ていると、新規ファイルを起こして、そこで終わりです。
新規ファイルには名前は付いていなく、Aファイルからの転写もできていません。
転写先が結合しているセルもあります。

お手数ばかりかけて申し訳ございません。
回答お待ちしております！

補足

＞転写先が結合しているセルもあります。

大変失礼しました。
転記先のセルの中にはいくつかのセルを結合したものもあり、結合したセルを選択すること自体が何らかの障壁になるかと思って記しました。

関係なければ無視してくださって結構です。

よろしくおねがいします！

回答No.2

merlionXX

merlionXXです。

> デバックを選択すると、下記の一文が黄色く反転しています。
> ActiveWorkbook.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop")

あなたのデスクトップのパスを取得する部分ですね。
ここがエラーですか・・・。
あなたのエクセルのバージョンは何でしょう？

お礼

ありがとうございます。
本来なら最初の質問で記しておくべきでした。すいません。

エクセルのバージョンは２００３です。

よろしくお願いします。

回答No.1

merlionXX

一例です。
Aファイルの2行目からデータがあるものとしています。
シート名が不明だったので、A,BファイルともにSheet1としています。
Bファイルは、B.xls　としていますが実情に合わせてください。
以下のマクロはAファイルの標準モジュールに記入してください。
実行時にはABファイルともに開いておいてください。

Sub test01()
　　Dim wb As Workbook
　　Dim ws(1) As Worksheet
　　Dim myW, myX
　　Dim i As Long, n As Long
　　Set wb = Workbooks("B.xls") 'Bファイル指定
　　Set ws(0) = ThisWorkbook.Sheets("Sheet1") 'Aファイルの転記元シート指定
　　Set ws(1) = wb.Sheets("Sheet1") 'Bファイルの転記先シート指定

　　myW = Split("B,C,D,E,F,G,H,I,L,M,N", ",")
　　myX = Split("J5,H2,D3,D7,F7,I7,D8,C10,D19,F19,C22", ",")

　　For n = 2 To ws(0).Cells(Rows.Count, "A").End(xlUp).Row
　　　　For i = LBound(myW) To UBound(myW)
　　　　　　ws(1).Range(myX(i)).Value = ws(0).Range(myW(i) & n).Value
　　　　Next i
　　　　ws(1).Copy
　　　　ActiveWorkbook.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ws(1).Range("J5").Value
　　　　ActiveWindow.Close (False)
　　Next n

End Sub

お礼

さっそくご教示いただきありがとうございます。
実行してみたところ、下記のようなエラーが出ました。

実行時エラー１００４

ファイルにアクセスできませんでした。次のいずれかを行ってみてください。
？指定したフォルダがあることを確認します
？ファイルを含むフォルダが読み取り専用になっていないことを確認します
？指定したファイルの名前に次のいずれかの文字も含まれていないことを確認します
<>?[]|:
？ファイル名およびパス名が半角218文字より長くないことを確認します

上から順番に確認しましたが、特に引っかかるものは見当たりません。
A、BどちらもデスクトップにA、Bという名前で保存しています。
シート名もA、BともにSheet1です。

デバックを選択すると、下記の一文が黄色く反転しています。

　ActiveWorkbook.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop")

文中にエラーの原因があるのでしょうか？
教えてください！！！

また出来ましたら、Aファイルの3行目からデータがあるものとして頂けると本当に助かります。

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