エクセルVBAが途中で止まります

このQ&Aのポイント
  • エクセルVBAでブックの結合マクロを作成しましたが、ブック数が900以上の場合に処理が停止してしまいます。
  • ブック数が900以下では正常に動作するため、原因としてはブック数が増えると処理が遅くなり、途中で停止してしまう可能性があります。
  • また、コピー元のブックにはテキストデータのみで、ファイル名も短くしてみたりしましたが解決しませんでした。対策としては、処理速度を上げるためにマクロの最適化やメモリの確保などを行うことが考えられます。
回答を見る
  • ベストアンサー

エクセルVBAが途中で止まります

以前別のカテゴリで質問したのですが、そちらでは解決出来なかったので、こちらで改めて質問します。 下記のマクロで、一つのブックからSheet1だけをコピーして来て、少し処理をし、元のブックを閉じるというもので、ブックの数は多くて3000程、少ない時は300位です。 で、このマクロだと900位までですと最後まで行くのですが、それを超えるとリストが95位で止まってしまいます。 自宅で別データを作ってやってみるとうまくいきました。 コピー元のブックにはテキストデータのみで、200文字から500文字程度の大きさしかありません。 ファイル名も50文字程度の物を全部20文字程度まで短くしてもみましたが、ダメでした。 どうかお知恵をお貸しください。 Sub ★1★ブックの結合() Dim sFile As String Dim sWB As Workbook, dWB As Workbook, aWB As Workbook Dim dSheetCount As Long Dim i As Long Dim SOURCE_DIR As String 'エクセルデータに変換されたファイルのあるフォルダを選択します。 MsgBox "エクセルに変換されたデータのフォルダを選択" With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then SOURCE_DIR = .SelectedItems(1) & "\" End If End With Application.ScreenUpdating = False '指定したフォルダ内にあるブックのファイル名を取得 sFile = Dir(SOURCE_DIR & "*.xls") 'フォルダ内にブックが無ければ終了 If sFile = "" Then Exit Sub '集約用ブックを作成 Set dWB = Workbooks.Add '転記マクロの中のDMリストシートをコピーする Workbooks("転記用マクロ.xlsm").Worksheets("DMリスト").Copy Before:=dWB.Worksheets("Sheet1") Application.DisplayAlerts = False Worksheets(Array("Sheet1", "sheet2", "sheet3")).Select ActiveWindow.SelectedSheets.Delete Application.DisplayAlerts = True '集約用ブック作成時のシート数を取得 dSheetCount = dWB.Worksheets.Count Do 'コピー元のブックを開く Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile) 'コピー元のsheet1を集約用ブックにコピー sWB.Worksheets("sheet1").Copy After:=dWB.Worksheets(dWB.Sheets.Count) シート転記 'コピー元ファイルを閉じる Application.DisplayAlerts = False sWB.Close Application.DisplayAlerts = True 'セルA2の名前を変更する 'シート名をセルA2の値に変更 'ActiveSheet.Name = Range("A2").Value '次のブックのファイル名を取得 sFile = Dir() Loop While sFile <> "" '集約用ブックを保存する 'dWB.SaveAs Filename:=DEST_FILE Application.ScreenUpdating = False End Sub

質問者が選んだベストアンサー

  • ベストアンサー
回答No.4

http://okwave.jp/qa/q8750372.html 例えば、30ファイルあっても10ファイルしか読み込まれない事があり、 エラーメッセージもない、何事もなく終了するが10ファイルしか処理されていない、 常に発生する訳ではなく、マシンが変われば同じデータでもOKだったり、 データが少し変わればOKだったりする。 なので、昨日までOKだったのに、今日データが変わった為、急にダメになったりする。 もし、10ファイル目で発生した場合、何度実行しても必ず、10ファイル目までしか処理されない。 そのファイルがおかしいかと思い、その前後の2~3ファイルを削除しても、 やっぱり、10ファイル目(さっきとは違うファイル)までしか処理されない、 という恐ろしいバグがExcel VBAにありますが、それじゃないですかね? While文などのループの中に、ワークブックのオープンがあると、 何度目かでオープンが実行されず、エラーなしでスルンと終わります。 回避方法は、Open 文の前に DoEvets の1行を書く事。 だいたいこれで直りますが、これで直らなかったマクロもあったので、 Open 文の後ろにも DoEvets の1行を書いて、前後を DoEvets ではさむと直りました。 安全(?)の為、前後をはさんでおいた方が良いと思います。 こんな感じ: DoEvents Workbooks.Open aaa DoEvents かなり前(1年くらい?)にハマりググりまくったところ、ほとんど情報はなかったですが、 1人だけ、自分の質問に「直った」と自己回答している方がいて、Open文の前にDoEvetsをつけたら直ったそうです。 半信半疑で真似たら私も直りました。 何故、これで直るのかはわかりませんが、DoEvetsを外すと見事に再現し、DoEvetsではさむとピタッと直ります。 ググりまくった際、とても情報が少なく、こんなに顕著に再現するのに、 何故、情報が少ないのかは不思議に思いました。

ngttyy
質問者

お礼

ご回答があった中で一番単純そうでしたので、一番初めに試した所、本当に何の問題もなく最後まで処理して完了しました。 1700でも1400でも大丈夫でした! どこを探しても見つからなかった答えがあっさりと解決しました。 DoEventoの事も全く知らなかったので、勉強になりました。 本当にありがとうございました。

その他の回答 (4)

  • hallo-2007
  • ベストアンサー率41% (888/2115)
回答No.5

こんな事を書くと答えにならないかもしれませんが。 うまくいった時の結果は、シート数が3000枚ですよね。 エクセルのシート最大数はヴァージョンにもよりますが 多くはメモリーで決まるようです。 メモリーなので、貼り付けているシートの内容も影響します。 つまり、やろうとしていることに無理があると思います。 試しに、シートを追加して、内容をコピーするVBAを実行してみましたが 途中途中で挙動不審になり、終了したシートを確認していったら 102枚目に、編集できないシートがありました。 考え方ですが、他のブックの内容を、データとして 一枚のシートへひたすら縦方向へ追加していく方法を検討してみてください。 エクセルでシートを増やしていくデータの管理はパソコンに負担ですし その手のデータでは集計もグラフも作れないでしょう。

ngttyy
質問者

お礼

回答をありがとうございました。 このマクロはそのような処理をしながら進んで行くようにしていますが、何故か途中で終わってしまうので、悩んでいました。 また何かありましたらどうぞよろしくお願いします。

  • pringlez
  • ベストアンサー率36% (598/1630)
回答No.3

>何行目で止まるかはわかりません。 >数千のブックがあるのに、出来上がったリストは >90代程度しか出来ていなくて、エラーも何もなく終わってしまいます。 そもそもプログラムで問題が起きたときにまず最初に確認すべきことは、プログラムが正常終了しているのか異常終了しているのか確認することです。 「Do」の前に 「Debug.Print("ループ開始")」を 「Loop While sFile <> ""」の後ろに 「Debug.Print("ループ終了")」を書いて実行してみてください。 するとイミディエイトウインドウにメッセージが表示されます。 もしも「ループ開始」しか表示されないようであれば処理が途中で止まっているということです。 ループ内でもメッセージを出力する処理を何個所か書いて、どこで終了しているのか特定しましょう。 もしも「ループ終了」が表示されるのなら、おそらく処理は正常終了しています。95ファイル処理して終了するのなら、「対象ファイル」は物理的に95しか存在していないという可能性もあります。 Dirコマンドでオプション無指定で対象になるのは標準ファイルだけです。読み取り専用属性等のファイルは対象になりません。それが原因かもしれません。もしここが原因なら、すべてを標準ファイルにするか、プログラムを以下のように変更してみるといいと思います。 「sFile = Dir(SOURCE_DIR & "*.xls", 1)」とか 「sFile = Dir(SOURCE_DIR & "*.xls", 3)」とか。

ngttyy
質問者

お礼

丁寧なご回答をありがとうございました。 回答をいただいた中で、簡単な物から試してみましたら、他の方の回答であっさりと解決してしまいました。 また躓きましたらこちらも次回参考にさせていただきますね。 どうぞ今後ともよろしくお願いします。

  • bin-chan
  • ベストアンサー率33% (1403/4213)
回答No.2

前の質問へのリンクですね。 何らかの経過があるならば、と思ったので。 何とも不思議な状態ですね。 時間がかかっても > Application.ScreenUpdating = False はコメントアウトしておくとか。 上手く行かない時、他のウインドウ操作したりせずに、じっと待つ。 そのためにはスクリーンセイバー・省電力は解除 > 'コピー元ファイルを閉じる > Application.DisplayAlerts = False > sWB.Close > Application.DisplayAlerts = True クローズした後 'コピー元ファイルを閉じる Application.DisplayAlerts = False sWB.Close Set sWB = Nothing ’追加してみるとどうなります? Application.DisplayAlerts = True あと、気になったのがココ > '集約用ブックを保存する > 'dWB.SaveAs Filename:=DEST_FILE 本番ではコメントアウトを解除してありますか?

ngttyy
質問者

お礼

素早いご回答をありがとうございました。 確かに一連の経過がありました。質問が杜撰で申し訳ありませんでした。 今後は過去の質問とのリンクも合わせて投稿させていただきます。 他の方の回答で解決しましたので、また躓いた時に参考にさせて下さい。 本当にありがとうございました。

  • bin-chan
  • ベストアンサー率33% (1403/4213)
回答No.1

> それを超えるとリストが9 5位で止まってしまいます。 「どこの行で」「どう」止まる? ・エラーメッセージは出ますか?出るなら何と書いてますか?どこの行ですか? ・何もエラーは出ないが目的の結果が得られない? > 自宅で別データを作ってやってみるとうまくいきました。 ・データによって、うまく行く/行かないがあるなら、両方で同じデータを用いることができますか? 続きの質問なら、せめてアンカーを付けてはどうでしょう?

ngttyy
質問者

お礼

大変助かりました。 ありがとうございました。

ngttyy
質問者

補足

早速ありがとうございます。 アンカーなるものがちょっとわからないのですが、以前した質問へのリンクということでしょうか? その時の質問はレスが付かなかったため、削除しました。 何行目で止まるかはわかりません。 数千のブックがあるのに、出来上がったリストは90代程度しか出来ていなくて、エラーも何もなく終わってしまいます。 大体いつも同じ位の所で終わるようですが、200位の時でも最後までリストを作ってくれることもあります。 自宅にデータを持って帰ることは出来ないので、大体似たような物を作り、コピーしてきた後の動きも少し単純にしています。 ですが以前、シートをコピーした後の動きをつけずに、ただひたすらシートをコピーしてくるだけのものを作ってみたのですが、その時も同じように90過ぎ位で終了してしまいました。 データが大きくなってしまうのが原因かと思い、いっそのことコピーした後の動きを一緒にして、データが大きくならないようにしてみたのですが、やっぱり同じことでした。

関連するQ&A

  • VBAで複数シートをまとめたい

    VBAを作るのは今回が初めてで行き詰ってしまいました。 フォルダ内の「.xlsx」4つのファイルのSheet1(4つともSheet1です) を統合.xLsmの1月シートのb2~値でコーピー貼り付けを行いたいのですが、 下記のものでやっていけば出来のかなと思ってますが、ご教授お願い致します。 Private Sub CommandButton1_Click() Dim sFile As String Dim sWB As Workbook, dWB As Workbook Dim dSheetCount As Long Dim i As Long Dim c As Long Dim ws As Worksheet Debug.Print (ws.Index) Const SOURCE_DIR As String = "C:\Users\KWEUSER\Desktop\data\" Application.ScreenUpdating = False '指定したフォルダ内にあるブックのファイル名を取得 For c = 1 To 4 sFile = Dir(SOURCE_DIR & "*.xlsx") 'フォルダ内にブックがなければ終了 If sFile = "" Then Exit Sub '集約用ブックを作成 Set dWB = Workbooks.Add '集約用ブック作成時のシート数を取得 dSheetCount = dWB.Worksheets.Count Do 'コピー元のブックを開く Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile) 'コピー元の c (1,2,3,4,5)シートを集約用ブックにコピー sWB.Worksheets(c).Copy After:=dWB.Worksheets(dSheetCount) 'シート名をファイル名に ActiveSheet.Name = sFile 'コピー元ファイルを閉じる sWB.Close '次のブックのファイル名を取得 sFile = Dir() Loop While sFile <> "" '集約用ブック作成時にあったシートを削除 Application.DisplayAlerts = False For i = dSheetCount To 1 Step -1 dWB.Worksheets(i).Delete Next i Application.DisplayAlerts = True '集約用ブックを保存して閉じる dWB.SaveAs Filename:="C:\Users\KWEUSER\Desktop\data\" & c & ".xlsx" dWB.Close Next Application.ScreenUpdating = False End Sub

  • VBAの質問です。

    VBAの質問です。 以下のプログラムで、4列おきにコピーしたい時はどうすればいいでしょうか? 1つのフォルダの中に集約第1期・集約第2期・集約第3期という名前の3つのファイルがあり、 その3つのファイル全てに「結果」というシートがあります。 この「結果」シートのC4:AU37の数値をコピーします。 コピーした数値を、集約第3期のファイルの中にある「集計用シート」のC2から貼り付けしていきたいのですが、 この時に、4列おきにはりつけたいと思っています。 集約第1期ファイル-結果-C4の列→集約第3期ファイル-集計用シート-C2の列から4列おきに 集約第2期ファイル-結果-C4の列→集約第3期ファイル-集計用シート-C3の列から4列おきに 集約第3期ファイル-結果-C4の列→集約第3期ファイル-集計用シート-C4の列から4列おきに といった具合です。 集約第3期ファイル-集計用シート-C5の列は空白し、C6からまた貼り付けます。 どこをどう直せば良いでしょうか? Sub データ抽出() Dim i As Long Dim flg As Boolean Dim myWb As Workbook Dim myWbName As String Application.ScreenUpdating = False ChDrive ThisWorkbook.Path ChDir ThisWorkbook.Path ThisWorkbook.Worksheets("集計用シート").Range("C2:EG35").Clear For i = 1 To 3 flg = False myWbName = "集約第" & i & "期.xls" If myWbName <> ThisWorkbook.Name Then For Each myWb In Workbooks If myWb.Name = myWbName Then flg = True Next myWb If flg = False Then Workbooks.Open Filename:=myWbName Else Workbooks(myWbName).Activate MsgBox myWbName & "を閉じてから再実行してください。" Exit Sub End If End If Worksheets("結果").Range("C4:AU37").Copy ThisWorkbook.Worksheets("集計用シート").Range("C2").Offset(, 45 * (i - 1)).PasteSpecial Paste:=xlPasteValues If myWbName <> ThisWorkbook.Name Then Application.DisplayAlerts = False Workbooks(myWbName).Close SaveChanges:=False Application.DisplayAlerts = True End If Next i Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

  • Excelマクロについての質問です。

    Excelのマクロについての質問です。 マクロについての質問です。 以下のようなマクロを作成しました。 このマクロを動作させているのはこのマクロを作成したファイル上です。 Sub Macro9() Dim WBA As Workbook Dim WBB As Workbook Dim WSA As Worksheet Dim WSB As Worksheet Set WBA = Workbooks("A") Set WBB = Workbooks("B") Set WSB = WBB.Worksheets("1") For i = 100 To 3000 Step 20 Worksheets.Add Before:=Worksheets("Sheet1") Dim k As String k = i ActiveSheet.Name = (k / 100) Set WSA = WBA.Worksheets(k / 100) WSB.Range("A1:AY30").Copy Destination:=WSA.Range("A1") WSA.Range("D4:I30").Clear WSA.Range("Q4:V30").Clear WSA.Range("AD4:AI30").Clear WSA.Range("AQ4:AV30").Clear Next i Application.DisplayAlerts = False Sheets("Sheet1").Delete Application.DisplayAlerts = True Application.DisplayAlerts = False Sheets("Sheet2").Delete Application.DisplayAlerts = True Application.DisplayAlerts = False Sheets("Sheet3").Delete Application.DisplayAlerts = True End Sub そこで質問ですが、このマクロを作動させると何のエラーの表示もなく最後まで動作は完了します。 ですが、シートの作成は30まで作成できてもその後のセルのコピー&ペーストはなぜかシート6.8までしかできていません(7~30までのシートはシート作成はできているのですがコピペのみが実行されず空白のままになっています。) シートもコピペも両方ともシート30まで完了するにはどの点を改善すればいいのでしょうか? 知恵が足りずどうしても直す事が出来ません。 長文申し訳ございませんが是非皆さまのお知恵をお貸しください。 宜しくお願い致します。

  • マクロでのワイルドカードの使い方について

    マクロ初心者です! 下記の動きを実現したいです。 (1)ファイル「*あいう*」(※)の「シート#1」のF5→AE24までの値をコピー →上記の値をすべて加算し、「貼り付け先ファイル」のF5→AE24に貼り付け ※「某フォルダ」に存在する、ファイル名に「あいう」を含むすべてのファイル(ファイル数は可変)が対象 (2)上記を同様の動きを、範囲のすべてのセルでなく、 (F25:F42)、(H25:H42)、、~(AD25:AD42)と1列ごとに対して行う 方々で知識のある方からご助力いただき、 下記の「それっぽい」記述までは辿り着いたのですが、上手く動かず。。 また、(1)と(2)は1つにできるのでは?とも推測してますが、どのように書けば間違いないのかわからない状況です…! 知識のある方から、間違いや改善点などご教示いただけたらとてもうれしいです。 Sub (1)() Dim folder As String Dim dws As Worksheet Dim sfile1 As String Dim swb1 As Workbook Dim adr As String folder = "C:\Users\某フォルダ\" Set dws = ThisWorkbook.Worksheets("貼り付け先シート") sfile1 = Dir(folder & "*あいう*.xlsm") If sfile1 = "" Then Exit Sub Set swb1 = Workbooks.Open(folder & sfile1) adr = Range(Cells(5, 6), Cells(24, 31)).Address(0, 0, 1) swb1.Sheets("シート#1").Range(adr).Copy dws.Range(adr).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd swb1.Close False End Sub Sub (2)() ((1)と同じ宣言) Dim c As Integer folder = "C:\Users\某フォルダ\" Set dws = ThisWorkbook.Worksheets("貼り付け先シート") sfile1 = Dir(folder & "*あいう*.xlsm") If sfile1 = "" Then Exit Sub Set swb1 = Workbooks.Open(folder & sfile1) For c = 6 To 30 Step 2 adr = Range(Cells(25, c), Cells(42, c)).Address(0, 0, 1) swb1.Sheets("シート#1").Range(adr).Copy dws.Range(adr).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd Next swb1.Close False End Sub

  • Excel VBA 非表示の別ブックへシートコピー

    Excel2010のVBAで、別のExcelブックを非表示で開いて、 シートをコピーすると、 「実行時エラー'1004':WorksheetクラスのCopyメソッドが失敗しました。」 というエラーが出て、正しくシートをコピーすることができません。 (1)のように自分のブックへはシートをコピーすることはできるのですが、 (2)のように別のExcelブック上でシートをコピーする場合と (3)のように別のExcelブック上にシートをコピーする場合の いずれも同様のエラーになります。 どのように記述すれば(2)と(3)でもコピーすることができるのでしょうか。 ------------------------------------------------------------- Sub test()  Dim newEx As Excel.Workbook  Dim newFile As String  newFile = ThisWorkbook.Path & "\New_Book.xlsx"  Set newEx = Workbooks.Open(newFile, UpdateLinks:=0)  Application.Windows("New_Book.xlsx").Visible = False  '(1)New_BookのSheet3を自分のブックにコピーする (正常)  newEx.Worksheets("Sheet3").Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)  '(2)New_BookのSheet3をNew_Bookにコピーする (エラー)  newEx.Worksheets("Sheet3").Copy after:=newEx.Sheets(newEx.Sheets.Count)  '(3)自分のブックのSheet3をNew_Bookにコピーする (エラー)  ThisWorkbook.Worksheets("Sheet3").Copy after:=newEx.Sheets(newEx.Sheets.Count)  Application.Windows("New_Book.xlsx").Visible = True  Application.DisplayAlerts = False  newEx.Save  newEx.Close  Application.DisplayAlerts = True  Set newEx = Nothing End Sub -------------------------------------------------------------

  • VBA コピペの途中でエラーになってしまいます。

    以前、質問させて頂き、マクロでしたい事の記述方法を教えて頂きました。 ご教示頂いたマクロ記述に更に手を加えて、下記のように記述しました。 したいことは、一つのフォルダにExcel Bookが120ほどあり、その中のマクロを組んだ集計用Book以外のBookから同じ名前のシート”結果”をコピーして、コピペされたシートは1、2、3・・という名前にして集計用Bookに値貼り付けをする。。というものです。 ところが、下記のマクロを実行するとシート名25までコピペされるのですが、途中で ”問題が発生したため MICROSOFT OFFICE EXCELを 終了します。・・・・・” とエラーになってしまいます。 このエラーを回避して120ほどあるシートをマクロのある集計Bookへコピペするには、どのようにしたら良いでしょうか? ご存知の方がみえたら、ご教示下さい。宜しくお願いいたします。 <マクロの記述> Sub macro() Const Aフォルダ As String = "C:\Documents and Settings\Bic\デスクトップ\Aフォルダ\" Dim FileCounter As Integer Dim myName As String myName = Dir(Aフォルダ & "*.xls") FileCounter = 0 Application.ScreenUpdating = False Do While myName <> "" If myName <> ThisWorkbook.Name Then Application.DisplayAlerts = False Workbooks.Open Aフォルダ & myName On Error Resume Next Workbooks(myName).Worksheets("結果").Copy After:=ThisWorkbook.Worksheets(2 + FileCounter) If Err.Number = 0 Then ActiveSheet.Range("A1:L35").Copy ActiveSheet.Range("A1:L35").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False FileCounter = FileCounter + 1 ActiveSheet.Name = FileCounter End If On Error GoTo 0 Workbooks(myName).Close End If myName = Dir Application.DisplayAlerts = True Loop Application.ScreenUpdating = True End Sub

  • 【VBA】条件分岐について

    当方Excel2003です。 ○フォルダ内に入力用のブック(複数)とまとめ用ブック(一つ)が存在し ○すべてのブックにはシートが一つしかなく、タイトル行の位置はまとめブック含めすべて同じ構成である ○入力用ブックのシート名は「入力」、まとめ用ブックのシート名は「まとめ」である 前提で、入力用ブックのデータ入力域をまとめ用ブックに順次コピーをしようと作成中のものですが、 入力用のファイルにデータがきちんと入力域(B7~T7、以降B8~T8…と続きます)に入っているファイルでは問題ありませんが、 データの入力がなくタイトル行のみしかないファイルの場合、タイトル行を最終行と認識し、タイトル行を張り付けてしまいます。 上記のケースの場合、 Select Case ~End Selectの間に、さらに条件(データがなければ、あるいはタイトル行のみの場合はなにもせず次のファイルへ…)を足すのを考えたのですがどういうふうに変更したら良いのか どなたかご教示いただければ幸いです。 よろしくお願いいたします。 ちなみにA列は6行目までタイトル行で、A7から下に1,2,3…と番号を入力していますが、コピーの対象範囲外としています。 Sub 連続貼り付け() Dim sFile As String Dim c As Range Dim myPAth As String Application.ScreenUpdating = False sFile = Dir(ThisWorkbook.Path & "\*.xls", vbNormal) myPAth = ThisWorkbook.Path Do While 0 < Len(sFile)      With ThisWorkbook.Worksheets("まとめ")       Set c = .Range("B" & .Rows.Count).End(xlUp).Offset(1)      End With     Select Case sFile        Case ThisWorkbook.Name:        Case Else          With Workbooks.Open(Filename:=myPAth & "\" & sFile, ReadOnly:=True)              With .Worksheets(入力)                 .Range("B7", .Range("T" & .Rows.Count).End(xlUp)).Copy                     c.PasteSpecial xlPasteValues              End With             .Close SaveChanges:=False          End With      End Select      sFile = Dir()      Set c = Nothing   Loop   Application.ScreenUpdating = True   End Sub

  • ワイルドカードを用いたセルの値加算&貼り付け

    こんにちは! 下記動きを実現したく、他の質問で方々からご教示いただいた内容をヒントに 下記マクロを組んでみたのですが、実現したい動きになりませんでした。。 知識のある方がいらっしゃれば、間違いを指摘いただけると嬉しいです! <実現したい動き> このファイルの貼り付け先シートのRange(Cells(6, 5), Cells(32, 30))に、 下記条件を満たす全ての値を加算のうえ、ペーストする。 「指定フォルダ」に格納されている、ファイル名に「あいう」を含むファイル(※)の、「指定シート」のRange(Cells(6, 5), Cells(32, 30))に存在する値 ※「あいう」の前後は不一致OK。複数存在し、ファイル数は可変。 <下記マクロを動かした結果> 該当ファイルは複数格納されているが、そのうちの1ファイルのみの値がコピペされている。 Sub マクロ() ' Dim folder As String Dim dws As Worksheet Dim sfile1 As String Dim swb1 As Workbook Dim adr As String Dim c As Integer folder = "C:\Users\指定フォルダ\" Set dws = ThisWorkbook.Worksheets("貼り付け先シート#1") Range(Cells(6, 5), Cells(32, 30))=0 sfile1 = Dir(folder & "*あいう*.xlsm") If sfile1 = "" Then Exit Sub Set swb1 = Workbooks.Open(folder & sfile1) adr = Range(Cells(6, 5), Cells(32, 30)).Address(0, 0, 1) swb1.Sheets("あいう").Range(adr).Copy dws.Range(adr).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd Application.CutCopyMode = False swb1.Close False End Sub

  • Excel VBA 他のブックへ値を返す

    Excelで「備品」というブックと「不用品報告」というブックを作り、「備品」の方でボタンをクリックすると「不用品報告」の"一覧"というシートに順々に入力されるように組んでみました。 ※「備品」「不用品報告」は同じフォルダに入っています。 Application.ScreenUpdating = False Dim thisBook As Workbook Dim workBook1 As Workbook Dim lastrow2 As Long Set thisBook = ThisWorkbook Set workBook1 = Workbooks.Open(thisBook.Path & "\不用品報告.xlsx") lastrow2 = workBook1.Worksheets("廃棄一覧").Range("C" & Rows.Count).End(xlUp).Row + 1 workBook1.Worksheets("廃棄一覧").Range("G" & lastrow2).Value = thisBook.Worksheets("一覧").Cells(ActiveCell.Row, 15).Value workBook1.Worksheets("廃棄一覧").Range("H" & lastrow2).Value = "報告する" workBook1.Close SaveChanges:=True Application.ScreenUpdating = True MsgBox "廃棄処理が完了しました。不用品報告ファイルの一覧にデータが追加されています。", vbInformation, "廃棄処理" End If という形です。 「不用品報告」ブックにデータが飛ぶのですが、ActiveCell.Rowと設定しているにも関わらず一定の行のデータしか飛んでくれません。 ※例 5行目のデータを飛ばしたいのに(アクティブなセルは5行目のセルになっている状態)7行目のデータが入る という感じです。 違うブックにデータを飛ばすときには「ActiveCell~」は使えないのでしょうか。もしくはどこか不具合があるのでしょうか。 お詳しい方がいらっしゃいましたら、ご教授願います。

  • VBAでBOOKを開かずにプロパティ変更

    エクセル2013です。 特定のフォルダ内のエクセルのBOOKのプロパティの作成者をすべて変えようと思います。 いろいろ試して、以下のコードでできるようになりました。 しかし、下記のコードではいちいちファイルを開かなくてはなりませんのでサイズが大きかったり、数が多いと結構時間がかかります。 手作業でファイルのプロパティを変えるときは、エクスプローラで右クリックすれば開かなくとも簡単にできます。VBAでもファイルを開かずにプロパティを変更するにはどうすればよいのでしょうか?お教えいただければ幸いです。 Sub TEST20190710()   Dim myFdr As String, fnm As String   Dim wb As Workbook   Dim n As Long   Const NEW_AUTHOR As String = "emaxemax"      Application.ScreenUpdating = False   Application.EnableEvents = False   myFdr = "C:\Users\User\Documents\TEST01"   fnm = Dir(myFdr & "\*.xls?")   Do Until fnm = Empty     Set wb = Workbooks.Open(myFdr & "\" & fnm)     Application.DisplayAlerts = False     wb.BuiltinDocumentProperties("Author").Value = NEW_AUTHOR     wb.Close SaveChanges:=True     Application.DisplayAlerts = True     n = n + 1     fnm = Dir   Loop   Application.ScreenUpdating = True   Application.EnableEvents = True   MsgBox n & "件のブックを処理しましました。", vbInformation End Sub