[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBA セルの値をフォルダ内の他ブックへ値貼付けしたい』(初心者)
マクロ初心者です。
下記を行うVBAメソッドが上手くいきません。
まだまだ解らない点も多く…
ご教示いただけないでしょうか?
【状況】
TESTというフォルダに
0.xlsm
あ.xlsm
い.xlsm
う.xlsm
え.xlsm
お.xlsm
上記、同じ仕様の6つのブックがあります。
【行いたい事】
1つ目:
0.xlsmブックのシート1のA1セルとC1セルの値を
フォルダ内全ての、他ブックの
一番左のシートの同じセルへ値貼付けする。
2つ目:
貼付け後、0.xlsmブック以外の
他ブックの一番左のシートのみ印刷する。
3つ目:
フォルダ内全てのファイルを上書き保存して閉じる。
申し訳ありませんが、よろしくお願いいたします。
< 使用 Excel:Excel2007、使用 OS:Windows8 >
>>下記を行うVBAメソッドが上手くいきません。 なんていうメソッドですか? 出来れば個人情報がもしあれば、名称等、変えて コードをアップすれば、たくさん、アドバイスが ありますよ。。。きっと。。。 m(_ _)m (隠居じーさん) 2019/06/12(水) 15:38
ご指摘いただきありがとうございます。
動くようなメソッドまでたどり着いたのですが
全シート印刷されてしまいます。
一番左のシートのみを印刷させる方法はありますでしょうか?
(シート名は統一することも可能ですが統一させない方法があればそちらが希望です。)
また、下記メソッドより良い方法はありますでしょうか?
ご教示いただけると助かります。
Dim fileName As String Dim wsName As String: wsName = "TEST"
Application.ScreenUpdating = False Application.DisplayAlerts = False ChDir ThisWorkbook.Path fileName = Dir("*.xls?") Do While fileName <> "" If fileName <> ThisWorkbook.Name Then With Workbooks.Open(fileName)
ThisWorkbook.Worksheets(wsName).Range("A1").Copy .Worksheets(wsName).Range("A1")
ThisWorkbook.Worksheets(wsName).Range("C1").Copy .Worksheets(wsName).Range("C1")
.Worksheets(wsName).Range("A1").Select .PrintOut .Close savechanges:=True
End With
End If fileName = Dir() Loop Application.DisplayAlerts = True Application.ScreenUpdating = True
End Sub
よろしくお願いいたします。
(初心者) 2019/06/13(木) 13:22
.PrintOut ↓ .Worksheets(1).PrintOut
ワークシートには左から順にインデックス番号というものが振られていて、 Worksheets(1)は、インデックス番号が1番のもの(=左から1番目)という意味です(^^)
(虎) 2019/06/13(木) 14:04
虎 さん からご説明もあったようですが。私の勉強のため作ってみました。 きっともっとスマートな方法は有るかもしれませんが、何かの足しにでも。 A^^; Option Explicit Sub OneInstance() Const BBName As String = "0.xlsm" Dim TB As Workbook Dim WB As Workbook Dim Fnm As String Set TB = Workbooks(BBName) Fnm = Dir(TB.Path & "\" & "*.xls*") Do Until Fnm = "" If Fnm <> TB.Name Then Set WB = Workbooks.Open(TB.Path & "\" & Fnm) With WB.Worksheets(1) .Range("A1").Resize(, 3) = TB.Worksheets("シート1").Range("A1").Resize(, 3).Value .PrintPreview End With WB.Close True Set WB = Nothing End If DoEvents Fnm = Dir() Loop Set TB = Nothing End Sub (隠居じーさん) 2019/06/13(木) 14:50
お!いけない。。。 すみません。。。 >>0.xlsmブックのシート1のA1セルとC1セルの値を だったので 0.xlsmのシートは シート1 にしました TEST だったのですね ^^; テキトーに環境に合わせて下さいね。( ̄▽ ̄) 読込BOOKの方は全て左端のシートです。 でわ m(_ _)m (隠居じーさん) 2019/06/13(木) 14:59
ご返信が遅くなりまして申し訳ありません。
お教えいただきありがとうございました。
もしよろしければ、もう1点お教えいただきたいです。
こちらのブックをネットワークフォルダに
保存した場合の開くメソッドもお教えいただけないでしょうか?
↓現状↓
Sub TEST()
'
Dim fileName As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ChDir ThisWorkbook.Path
fileName = Dir("*.xls?")Do While fileName <> "" If fileName <> ThisWorkbook.Name Then With Workbooks.Open(fileName)
ThisWorkbook.Worksheets(1).Range("A1").Copy .Worksheets(1).Range("A1")
ThisWorkbook.Worksheets(1).Range("C1").Copy .Worksheets(1).Range("C1")
.Worksheets(1).Range("A1").Select .Worksheets(1).PrintOut .Close savechanges:=True End With End If fileName = Dir() Loop Application.DisplayAlerts = True Application.ScreenUpdating = True
End Sub
申し訳ありませんが、よろしくお願いいたします。
(初心者) 2019/06/18(火) 15:19
>こちらのブックをネットワークフォルダに 保存した場合の開くメソッドもお教えいただけないでしょうか?
↑の『こちらのブック』とは、最初の説明にあった『0.xlsm』のブックでしょうか? 『0.xlsm』ブックを『TEST』という名前のフォルダからネットワークフォルダに移動させたとき、 『TEST』フォルダにある他のブックをどうやって開けばいいのか?ということでしょうか?
(虎) 2019/06/18(火) 16:40
WSH(Windows Scripting Host)などで
net use \\pc_Name /user:User_Name Password
実行
vbaです ^^;
Workbooks.Open("\\pc_Name\D\TEST\0.xlsm")
WSH(Windows Scripting Host)などで
net use \\pc_Name /delete
実行
使用オブジェクトの後始末。。。
ネットに接続されていれば最初と、最後は要らないかもですね。
なお、WSHとかDOSコマンドに関してはお詳しい方の回答を
お待ちください。ヒントだけみたいな事で済みません。
(隠居じーさん) 2019/06/18(火) 17:18
ご返信が遅くなり申し訳ありません。
0、あ〜お.xlsmのブックの入っている
TESTフォルダごとネットワークフォルダへ移動させ
ネットワークフォルダの中のTESTフォルダ内にある
0.xlsmブックでVBAを実行したら、
あ〜お.xlsmのブックへ指定セルがコピペされ
上書き保存して、印刷して閉じる。
という形にしたいです。
隠居じーさん様
ヒントをいただきありがとうございます。
参考にして考えてみます。
(初心者) 2019/06/21(金) 06:08
(初心者) 2019/06/13(木) 13:22 のコードをちょっと整理すると↓のようになるとおもいますが、どの部分かでエラーでちゃいますか?
Sub TEST_改()
Dim fileName As String Dim MySH As Worksheet Set MySH = Worksheets(1)
fileName = Dir(ThisWorkbook.Path & "*.xls?")
Do Until fileName = "" If fileName <> ThisWorkbook.Name Then With Workbooks.Open(ThisWorkbook.Path & fileName)
'▼コピー MySH.Range("A1").Copy .Worksheets(1).Range("A1") MySH.Range("C1").Copy .Worksheets(1).Range("C1")
'▼プリントアウト .Worksheets(1).PrintOut
'▼上書保存 .Save
'▼閉じる .Close
End With
fileName = Dir() Loop
End Sub
しいて言えば、する必要ない「ChDir」しているのが問題だったかも・・・
(ファイル階層が深い場合の対応だったとしても別のアプローチがあるとおもいます)
(もこな2) 2019/06/21(金) 06:48
Sub TEST_改修正()
Dim fileName As String Dim MySH As Worksheet Set MySH = Worksheets(1)
fileName = Dir(ThisWorkbook.Path & "*.xls?")
Do Until fileName = "" If fileName <> ThisWorkbook.Name Then With Workbooks.Open(ThisWorkbook.Path & fileName)
'▼コピー MySH.Range("A1").Copy .Worksheets(1).Range("A1") MySH.Range("C1").Copy .Worksheets(1).Range("C1")
'▼プリントアウト .Worksheets(1).PrintOut
'▼上書保存 .Save
'▼閉じる .Close
End With End If
fileName = Dir() Loop
End Sub
※コンパイルは通るように修正しましたが、実行テストまではしていないので他にもミスがあるかもしれません。
(もこな2) 2019/06/21(金) 07:14
すでにもこな2さんからコメントいただいている通り、『0.xlsm』ファイルとその他のファイルが 同じ場所(フォルダ)にある場合、元のコードで特に問題ないのかな?と思います(^^)
もしもエラーが発生するようであれば、エラーが発生する場所とエラーの内容を教えてもらえると、 いいかと思います。
(虎) 2019/06/21(金) 08:34
Sub さんぷる() Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") Dim MyFile As Object
For Each MyFile In FSO.GetFolder(ThisWorkbook.Path).Files Debug.Print MyFile.Name Next
End Sub
(もこな2) 2019/06/24(月) 18:27
虎様よりご質問いただいたエラー箇所の件ですが。
元のコードでも、もこな2様がお作りいただいたコードでも
エラーは発生しませんが、コピペも上書き保存も印刷も実行されない。
という状況です。
ネットワークフォルダへ入れた場合のみ上記の実行不可となります。
どなたか原因がわかる方いらっしゃいますでしょうか?
(初心者) 2019/06/28(金) 08:30
(もこな2) 2019/06/28(金) 08:50
もう一度確認させてください。 『0.xlsm』ブックと他のブックは同じフォルダ内の同じ階層にあるんですよね? 同じフォルダ内だけど、実は階層が違うよってことはないですよね? 『0.xlsm』ブックの場所は、 ネットワークフォルダ →0.xlsm だけど、他のブックの場所は、 ネットワークフォルダ →別のフォルダ →他のブック →他のブック →他のブック とかではないですよね?という確認です。 伝わるかなぁ…。 文字だけで伝えようとすると難しいですね(^^;
なんとなくですが、そもそもブックを開くことに失敗しているような気がします…。 まずはステップ実行で、 >With Workbooks.Open(fileName) の部分でちゃんと他のブックが開かれるかを確認していただけたらと思います。
(虎) 2019/06/28(金) 09:05
早速ご回答いただきありがとうございます。
ネットワーク上にある
TESTフォルダ内に
0.xlsm
あ.xlsm
い.xlsm
う.xlsm
え.xlsm
お.xlsm
が存在しています。
マクロ実行ファイルは0ブックです。
虎様へお教えいただいた通りステップ実行しましたら
ご回答いただいた通り、他のブックは開かれず
フォルダの画面へ切り替わるのみでした。
(初心者) 2019/06/28(金) 09:29
やっぱりおんなじ場所なんですよねぇ…。
とりあえず、そこにマクロ有効ブック(.xlsmブック)を新規で作ってもらって、 標準モジュールに↓のコードを貼り付けて実行してもらったとき、シート1に 『0.xlsm』〜『お.xlsm』ブックまでの名前がちゃんと出てくるか確認してもらえますか? たぶんDirがうまくいってないと思うので…。
Option Explicit
Sub test()
Dim fname As String
fname = Dir(ThisWorkbook.Path & "\" & "*.xls?") Do Until fname = "" ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = _ fname fname = Dir() Loop
End Sub
これでうまくすべてのブックの名前を取れているなら、 >fileName = Dir("*.xls?")Do While fileName <> "" ここのDir(〜)までを↑のコードのDir(〜)に差し替えてもう一度トライしてみてください。 逆に↑のコードでブック名が取れないと、自分にはちょっとわからないかもしれないです…orz
(虎) 2019/06/28(金) 09:50
(1)ネットワークフォルダのフォルダパスとファイル名を組み合わせた【フルパス】が ↓みたいな感じになって256バイト(半角英数に換算して256文字を超えている \\File_Server\○○部\××課\■■プロジェクト\▲▲から引継ぎ〜〜〜\あ.xlsm
(2)Dir関数が Dir(256バイトを超えるパス) となり、「""」を返す (※ちょっと、ここ怪しいです。エラーになって何も格納されないから""のままなのかも・・)
(3)Do 〜 Loop で 「Do Until fileName = ""」なので、中身を実行する前に条件を満たしたと判定され 中身の部分はそっくり実行されなくなる。
(4)↑についてステップ実行すれば、どういう原因か(ループの中身が実行されていないこと)は 直ぐわかるけど、やらないから解らない 【←今ココ】
ステップ実行していて、)Dir関数の戻り値が""じゃないのは確認済みということであれば、予想外れごめんなさい。
違ってた場合は私には他に原因わからないし、合ってたとしても話をきいてもらえなさそなので撤退します。
(一応、フルパスが256バイトを超える場合の対処法は書いたつもりです。原因が推測通りであったら気が向いたときにでも試してみてください)
(もこな2) 2019/06/28(金) 10:27
ご教示いただいた通り新規ブック(ブック名:TEST)へ
上記コードを貼付け実行したところ、
シート1へTEST,0,あ〜おのブック名がセルへ入力されました。
その為、Dir(〜)を変更して下記コードにて実行しましたが
エラーが発生します。
発生箇所は
With Workbooks.Open(fileName)
でした。
========================================================================================
Sub TEST()
'
Dim fileName As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False ChDir ThisWorkbook.Path
fileName = Dir("*.xls?") Do While fileName <> ""
If fileName <> ThisWorkbook.Name Then With Workbooks.Open(fileName) '←エラー発生箇所
ThisWorkbook.Worksheets(1).Range("A1").Copy .Worksheets(1).Range("A1")
ThisWorkbook.Worksheets(1).Range("C1").Copy .Worksheets(1).Range("C1")
.Worksheets(1).Range("A1").Select .Worksheets(1).PrintOut .Close savechanges:=True End With End If fileName = Dir() Loop Application.DisplayAlerts = True Application.ScreenUpdating = True
End Sub
========================================================================================
捉え方が間違っておりましたら申し訳ありません。
(初心者) 2019/06/28(金) 10:42
ご回答ありがとうございます。
TESTフォルダまでのバイト数を確認したところ
152バイトでした。
また、虎様にお教えいただいたコードで
シート1へファイル名の記述ができたということは
Dir(〜)で問題ないという事でしょうか?
多々知識不足で申し訳ありません。
(初心者) 2019/06/28(金) 10:47
Sub TEST()
Dim fileName As String
Application.ScreenUpdating = False Application.DisplayAlerts = False ChDir ThisWorkbook.Path '←これいらなくなります
fileName = Dir("*.xls?") '←※ここを変えてください※ Dir("*.xls?")→Dir(ThisWorkbook.Path & "\" & "*.xls?") Do While fileName <> "" If fileName <> ThisWorkbook.Name Then With Workbooks.Open(fileName) ThisWorkbook.Worksheets(1).Range("A1").Copy .Worksheets(1).Range("A1") ThisWorkbook.Worksheets(1).Range("C1").Copy .Worksheets(1).Range("C1") .Worksheets(1).Range("A1").Select .Worksheets(1).PrintOut .Close savechanges:=True End With End If fileName = Dir() Loop Application.DisplayAlerts = True Application.ScreenUpdating = True
End Sub
なんかあとから読み返すと自分の説明だいぶわかりにくかったですね(^^; 勘違いさせてしまってすみません…m(_ _)m
↑のコードにコメントを付けた個所を変更してください。
(虎) 2019/06/28(金) 10:59
すみません…。 ↑の(虎) 2019/06/28(金) 10:59のコード↓に差し替えてくださいm(_ _)m
Sub TEST()
Dim fileName As String
Application.ScreenUpdating = False Application.DisplayAlerts = False ChDir ThisWorkbook.Path '←これいらなくなります
fileName = Dir("*.xls?") '←※ここを変えてください※ Dir("*.xls?")→Dir(ThisWorkbook.Path & "\" & "*.xls?") Do While fileName <> "" If fileName <> ThisWorkbook.Name Then With Workbooks.Open(fileName) '←※ここを変えてください※ With Workbooks.Open(fileName)→With Workbooks.Open(Thisworkbook.Path & "\" & fileName) ThisWorkbook.Worksheets(1).Range("A1").Copy .Worksheets(1).Range("A1") ThisWorkbook.Worksheets(1).Range("C1").Copy .Worksheets(1).Range("C1") .Worksheets(1).Range("A1").Select .Worksheets(1).PrintOut .Close savechanges:=True End With End If fileName = Dir() Loop Application.DisplayAlerts = True Application.ScreenUpdating = True
End Sub
(虎) 2019/06/28(金) 11:22
ちなみに、コメント通りに直してもらうと、もこな2さんの(もこな2) 2019/06/21(金) 07:14の コードとほぼ同じになります。 じゃあ、なんでもこな2さんのコードで動かなかったんだろう?ってところなのですが、 たぶん、 >With Workbooks.Open(ThisWorkbook.Path & fileName) のところの、"\"を忘れてるからかなぁ…(^^;
(虎) 2019/06/28(金) 11:39
申し訳ありません。
私のコードの記述が間違っておりました。
訂正したコードで実行しましたが
エラーにはなりませんが、また何も実行されずに終わりました。
下記、実行コードです。
========================================================================================
Sub TEST()
Dim fileName As String
Application.ScreenUpdating = False Application.DisplayAlerts = False
fileName = Dir(ThisWorkbook.Path & "\" & "*.xls?") Do While fileName <> "" If fileName <> ThisWorkbook.Name Then With Workbooks.Open(Thisworkbook.Path & "\" & fileName) ThisWorkbook.Worksheets(1).Range("A1").Copy .Worksheets(1).Range("A1") ThisWorkbook.Worksheets(1).Range("C1").Copy .Worksheets(1).Range("C1") .Worksheets(1).Range("A1").Select .Worksheets(1).PrintOut .Close savechanges:=True End With End If fileName = Dir() Loop Application.DisplayAlerts = True Application.ScreenUpdating = True
End Sub
========================================================================================
ネットワークフォルダでなくても実行されませんでした。
度々申し訳ありません。
(初心者) 2019/06/28(金) 11:55
[ABCDEF]・・・・・6バイトの文字列 [あいう]・・・・・6バイトの文字列(全角1文字は2バイト)
なので「ThisWorkbook.Path & "あ.xlsm"」が半角英数に換算して256文字を超えてないか というのが確認している点です。
Dir関数は、(半角英数換算で)256以上の【フルパス】を与えられても、うまく動作しないので、フォルダパス + ファイル名 で構成される【フルパス】が(半角英数換算で)256文字を超えるとマズイですと言っています。
したがって、フルパスの文字長が本当に152バイトなら私の想像は大外れなので無視してください。
ちなみに、「あ.xlsm」ブックを開いてアクティブにしてから、イミディエイトに「?LenB(ActiveWorkbook.fullname)」と入力すると、何バイト長なのか簡単に調べることが出来ます。
(もこな2) 2019/06/28(金) 12:00
こちらでは初心者さんが直してくれたコードでうごいてるんですよねぇ…なんでだろう? ちょっと原因がわからないです…orz
(虎) 2019/06/28(金) 12:15
分からなくて申し訳ありません。
イミディエイトウィンドウへ
「?LenB(ActiveWorkbook.fullname)」を入力してみたのですが
バイト数はどこに表示されますでしょうか?
一応バイト数を調べるサイトで
フォルダまでの文字を入れて確認してみたのですが…。
こちらの確認の仕方では異なりますか?
(初心者) 2019/06/28(金) 12:22
>0、あ〜お.xlsmのブックの入っている >TESTフォルダごとネットワークフォルダへ移動させ
(初心者) 2019/06/28(金) 11:55
のコードの
1) >fileName = Dir(ThisWorkbook.Path & "\" & "*.xls?") を CreateObject("WScript.Shell").CurrentDirectory = "\\何とか\かんとか\" fileName = Dir("*.xls?")
"\\何とか\かんとか\"を実際のネットワークパスに変更。
2) >With Workbooks.Open(Thisworkbook.Path & "\" & fileName) を With Workbooks.Open(fileName)
に変更して試しててください。
(seiya) 2019/06/28(金) 12:46
With Workbooks.Open(ThisWorkbook.Path & fileName)のところの、"\"を忘れてるからかなぁ…(^^; あっほんとうだ。ご指摘ありがとうございます。
やっぱりテストしないとダメですね・・・
>イミディエイトウィンドウへ
>「?LenB(ActiveWorkbook.fullname)」を入力してみたのですが
>バイト数はどこに表示されますでしょうか?
イミディエイトはどうなってますか?
言ったとおり、ネットワークドライブ上にある「あ.xlsm」を開いてアクティブにしてから
イミディエイトに「?LenB(ActiveWorkbook.fullname)」を入力してみたら
?LenB(ActiveWorkbook.fullname) 152
って表示されたなら、仰るとおり「あ.xlsm」のプルパスの長さは152バイトで合ってます。
ただ、(初心者) 2019/06/28(金) 11:55のコードでは私のミスは直したうえで
” 何も実行されずに終わりました”とのことなので、私には原因はわかりません。
(「ステップ実行したら、Do While〜 からloopまで一気に飛んじゃいます」だったらとりあえずの原因は解りますが。)
(もこな2) 2019/06/28(金) 12:49
こちらのコードを貼りなおして実行しましたら
ネットワークフォルダでもできました。
ご迷惑をおかけし申し訳ありませんでした。
ちなみにもこな2様にお教えいただいた方法で確認しましたら
バイト数は236でした…。
全然異なっておりました。すみませんでした。
下記コードで解決しました。
=====================================================================================
Sub TEST()
Dim fileName As String
Application.ScreenUpdating = False Application.DisplayAlerts = False
fileName = Dir(ThisWorkbook.Path & "\" & "*.xls?") Do While fileName <> "" If fileName <> ThisWorkbook.Name Then With Workbooks.Open(Thisworkbook.Path & "\" & fileName) ThisWorkbook.Worksheets(1).Range("A1").Copy .Worksheets(1).Range("A1") ThisWorkbook.Worksheets(1).Range("C1").Copy .Worksheets(1).Range("C1") .Worksheets(1).Range("A1").Select .Worksheets(1).PrintOut .Close savechanges:=True End With End If fileName = Dir() Loop Application.DisplayAlerts = True Application.ScreenUpdating = True
End Sub
=====================================================================================
記述間違えが無いよう、以後気を付けます。
ご対応ありがとうございました。
(初心者) 2019/06/28(金) 13:25
あぁ、よかった(^^) お疲れ様でした♪
(虎) 2019/06/28(金) 13:52
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.