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

解決済みの質問

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

マクロ初心者です!

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

(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

投稿日時 - 2019-11-20 14:59:22

QNo.9681150

困ってます

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

とりあえずこれで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

投稿日時 - 2019-11-20 16:16:25

お礼

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

投稿日時 - 2019-11-20 17:40:18

ANo.1

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

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

回答(2)

ANo.2

やはり、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

投稿日時 - 2019-11-20 17:29:09

あなたにオススメの質問