こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

こんにちは!
下記動きを実現したく、他の質問で方々からご教示いただいた内容をヒントに
下記マクロを組んでみたのですが、実現したい動きになりませんでした。。
知識のある方がいらっしゃれば、間違いを指摘いただけると嬉しいです!

<実現したい動き>
このファイルの貼り付け先シートの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

投稿日時 - 2019-11-22 16:37:41

QNo.9681940

困ってます

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

ちょっとエラーメッセージを検索したところ、コピー貼り付けを短時間で複数回行うとそのエラーが出るという情報がありました。
VBAの画面でF8キーでステップ実行してエラーが出なければ上記の可能性大です。

決定的にこれが改善策という情報が得られなかったのですが
感じとしては微妙に時間を置く(間を開ける)という処理がいいみたいです。

DoEvents
dws.Range(adr).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd

といった状態で出なくなる事もあるみたいです。

TimeValue("0:00:01")
の時間を延ばしたり貼り付けの前に
wTime = Now + TimeValue("0:00:01")
Application.Wait wTime
とするとエラーが出ないかもしれません。

投稿日時 - 2019-11-23 11:08:18

補足

ありがとうございます。。。無事に問題なく動くようになりました。
完結でわかりやすいご指摘で、とてもに参考になりました。。
ループの動きについてなど、自分でももうちょっと勉強してみます!!

投稿日時 - 2019-11-23 20:37:24

ANo.4

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(4)

ANo.3

指定フォルダの中のファイルのファイル名に、ワイルドカードの考えを指定して、1ステップで、該当複数名をコレクションなどとして、返してくれる仕組みはない。
Dir関数はその機能はない。
(たとえ、あっても、その後コレクションの1つ1つを捉えないと、話が進まないだろうが。)
だからフォルダーの中のファイル名(ブック名)の1つ1つを、調べる作業を
繰り返さないとならない。
今掴んだ1つのファイル名について、ワイルドカードのしくみで、該当する(語句を1部に含む)かどうかを調べるときに、ワイルドカードの考えは、使えるか、採用してない処理系か調べないとならない。使えるとして、
そして、指定フォルダの全ファイルを対象に、ファイルの名前のチェックを繰り返さないと、いけない。
このステップが、質問のコードに、ないのではないか?
VBAコード云々を言う前の問題だ。
もっと場数を踏むこと。

投稿日時 - 2019-11-22 21:13:46

お礼

ご指摘ありがとうございます!
まだVBA触りはじめて一週間も経ってないスーパー初心者で、場数が足りてないのです。。
DIR関数についてもっと勉強してみますね!

投稿日時 - 2019-11-22 22:58:41

ANo.2

> 原因がもしおわかりになれば、改善に向けてご教示いただけるととても嬉しいです。。

原因がいまひとつわからないのですが、

画面の表示の一時停止
ScreenUpdatingで最初と最後

ファイルを閉じるまでに1秒待機
wTime = Now + TimeValue("0:00:01") 'ここ追加しました3
Application.Wait wTime 'ここ追加しました4

swb1の開放
Set swb1 = Nothing 'ここ追加しました5

を追加してみました。


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

Dim wTime As Variant 'ここ追加しました1

Application.ScreenUpdating = False 'ここ追加しました2

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
Do While sfile1 <> ""
Set swb1 = Workbooks.Open(folder & sfile1)
adr = Range(Cells(6, 5), Cells(32, 30)).Address(0, 0, 1)
swb1.Sheets("シート#1").Range(adr).Copy
dws.Range(adr).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd

wTime = Now + TimeValue("0:00:01") 'ここ追加しました3
Application.Wait wTime 'ここ追加しました4

Application.CutCopyMode = False
swb1.Close False

Set swb1 = Nothing 'ここ追加しました5

sfile1 = Dir()
Loop

Application.ScreenUpdating = True 'ここ追加しました6

End Sub

投稿日時 - 2019-11-22 19:41:40

ANo.1

Do While~ Loopを入れるだけでいけると思います。

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
Do While sfile1 <> ""
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
sfile1 = Dir()
Loop
End Sub

投稿日時 - 2019-11-22 17:04:30

補足

ありがとうございます・・・!
実行してみたところ、「rangeクラスのPasteSpecialメソッドが失敗しました」とエラーが出てしましました。。
原因がもしおわかりになれば、改善に向けてご教示いただけるととても嬉しいです。。

投稿日時 - 2019-11-22 18:28:38

あなたにオススメの質問