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

質問

マクロ初心者です！

下記の動きを実現したいです。

(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

回答No.1

kkkkkm · ベストアンサー

とりあえずこれで1個希望通り動くかどうか
希望どおりだと
> ※「某フォルダ」に存在する、ファイル名に「あいう」を含むすべてのファイル(ファイル数は可変)が対象
こちらを追加で

Sub (2)()
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("貼り付け先シート")

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

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

お礼

びっくりするくらいちゃんと動きました。。。
ありがとうございます…！

回答No.2

nishi6

やはり、1列置きの処理で行数が倍になります。ご参考に。

Sub myAry()
　Dim Ary1 As Variant, Ary2 As Variant, Ary3 As Variant
　Dim myPath As String: myPath = "C:\Users\某フォルダ\"
　Dim FL As String
　Ary1 = Array(""): Ary2 = Array(""): Ary3 = Array("")

　Dim ct As Integer
　FL = Dir(myPath & "*あいう*.xlsm")
　While FL <> ""
　　ReDim Preserve Ary1(ct)
　　ReDim Preserve Ary2(ct)
　　ReDim Preserve Ary3(ct)
　　Ary1(ct) = "'" & myPath & "[" & FL & "]シート#1'!R5C6:R24C31"
　　Ary2(ct) = "'" & myPath & "[" & FL & "]シート#1'!"

　　FL = Dir(): ct = ct + 1
　Wend

　ActiveSheet.Range("F5").Select
　Selection.Consolidate Sources:=Ary1, _
　　　Function:=xlSum, TopRow:=False, LeftColumn:=False, CreateLinks:=False

　Dim c As Integer, F As Integer
　For c = 0 To 24 Step 2
　　For F = 0 To UBound(Ary2)
　　　Ary3(F) = Ary2(F) & "R25C" & (6 + c) & ":R42C" & (6 + c)
　　Next
　　Range("F25").Offset(0, c).Select
　　Selection.Consolidate Sources:=Ary3, _
　　　　Function:=xlSum, TopRow:=False, LeftColumn:=False, CreateLinks:=False
　Next
End Sub