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

質問

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

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

回答No.4

kkkkkm · ベストアンサー

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

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

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

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

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

補足

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

回答No.3

imogasi

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

お礼

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

回答No.2

kkkkkm

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

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

画面の表示の一時停止
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

回答No.1

kkkkkm

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

補足

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