マクロでループ構文がうまく使えません。。

質問

マクロ初心者です！
下記の動きを実現したく、マクロを組んでいます。

F列～AD列の間で、１列おきに下記処理を行う
「あいう」の指定sheetのF25→F42までの値をコピー
→「えお」の指定sheetのF25→F42までの値をコピー
→「貼り付け先ファイル」のF25→F42に上記2つの値を加算で貼り付け

下記の記述をF列、H列、、と地道に書いていくことで
形としては動くようになったのですが、これはループ構文を用いることができるのでは？
と思って試行錯誤をしているところです。が、上手くいきません。
どのようにしたらうまく動くのか、知識のある方からお力を借りたいです。。
よろしくお願いします。。

Sub マクロ()
Const xAdr As String = "(F25:F42)"
Dim buf As String

buf = Dir("C:某フォルダ\*あいう*.xlsm")
With Workbooks("貼り付け先ファイル.xlsm").Worksheets("貼り付け先シート")
Workbooks(buf).Worksheets("シート#1").Range(xAdr).Copy
.Range(xAdr).PasteSpecial Paste:=xlPasteValues

buf = Dir("C:\某フォルダ\*えお*.xlsm")
Workbooks(buf).Worksheets("シート#2").Range(xAdr).Copy
.Range(xAdr).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd

End With
End Sub

回答No.2

kkkkkm · ベストアンサー

Cells(25, i), Cells(42, i)
は文字列変数として利用することはできませんので
直接
Workbooks(buf).Worksheets("シート#1").Range(Cells(25, i), Cells(42, i)).Copy
にしてください。

以下はコピー貼り付けの所だけですが

Dim i As Long
これは↑↑Longがいいです。
With Workbooks("貼り付け先ファイル.xlsm").Worksheets("貼り付け先シート")
For i = 6 To 30 Step 2
Workbooks(buf).Worksheets("シート#1").Range(Cells(25, i), Cells(42, i)).Copy
.Range(.Cells(25, i), .Cells(42, i)).PasteSpecial Paste:=xlPasteValues
Next i
End With

これでコピー貼り付けをF列からD列まで一つ飛ばしで行います。なお、動作確認はしていませんので何かしら落ちがあるかもしれません。

なお、
buf =Dir("C:某フォルダ\*あいう*.xlsm")
ではファイルは開かないので

tmp="C:某フォルダ\" & buf

にしてtmpのファイルをコピー貼り付けのコードの前で開いてください。
用が終わったら.Closeも忘れずに。

お礼

こちら参考になせていただき、無事希望する動きを実現することができました！
ありがとうございます！

回答No.5

nishi6

単に２つのブックのシート間の足し算？
２つのブックを開く必要はありません。セルの指定はRC形式です。
１行おきの偶数列（G列とか）に何も入力が無ければ、１行マクロになりそうです。

Sub Add2Sheets()
　Dim c As Integer, cc As String
　For c = 0 To 24 Step 2
　　Worksheets("貼り付け先シート").Range("F25").Offset(0, c).Select
　　cc = "R25C" & (6 + c) & ":R42C" & (6 + c)
　　Selection.Consolidate Sources:=Array( _
　　　　"'C:某フォルダ\[*あいう*.xlsm]シート#1'!" & cc, _
　　　　"'C:某フォルダ\[*えお*.xlsm]シート#2'!" & cc), _
　　　　Function:=xlSum, TopRow:=False, LeftColumn:=False, CreateLinks:=False
　Next
End Sub

回答No.4

kkkkkm

コピー貼り付けだと遅い感じがしたのでコピー貼り付けじゃないモードで
貼り付け先ファイルに加算していきます。画面表示を止めていますので終了までセルの値は変化しません。
もしエラーで止まった場合
Sub TestErr()
Application.ScreenUpdating = True
End Sub
これを実行してください。画面表示オフになっているのをオンにします。

Sub Test()
Dim buf As String, i As Long, j As Long, k As Long
Dim FileName(1 To 2) As String, FilePath As String
Dim ShName(1 To 2) As String
Dim wb As Workbook

FilePath = "C:\某フォルダ\"
FileName(1) = "*あいう*.xlsm"
ShName(1) = "シート#1"
FileName(2) = "*えお*.xlsm"
ShName(2) = "シート#2"

Application.ScreenUpdating = False
For k = 1 To UBound(FileName)
With Workbooks("貼り付け先ファイル.xlsm").Worksheets("貼り付け先シート")
buf = Dir(FilePath & FileName(k))
Do While buf <> ""
buf = FilePath & buf
Set wb = Workbooks.Open(FileName:=buf, UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
For i = 6 To 30 Step 2
For j = 25 To 42
.Cells(j, i).Value = .Cells(j, i).Value + wb.Worksheets(ShName(k)).Cells(j, i).Value
Next j
Next i
wb.Close
Set wb = Nothing
buf = Dir()
Loop
End With
Next k
Application.ScreenUpdating = True
End Sub

回答No.3

imogasi

Workbookの課題を、テストデータ作成が手数なので、
同一WorkbookのSheet1とSheet2の課題に変えてやってみました。
参考になれば。
また「F列～AD列の間」という条件を、F～J列３列に少なくしました。
これは原案に変更が簡単ですが。
ーーー
例データ
Sheet1　F-J列　２－１２行
10 11 12
10 11 12
10 11 12
10 11 12
10 11 12
10 11 12
10 11 12
10 11 12
10 11 12
10 11 12
10 11 12
Sheet２　F-J列　２－１２行
20 30 40
20 30 40
20 30 40
20 30 40
20 30 40
20 30 40
20 30 40
20 30 40
20 30 40
20 30 40
20 30 40
標準モジュールに
コード
Sub test07()
Dim cl As Range
Dim sh(3)
Set sh(1) = Worksheets("Sheet1")
Set sh(2) = Worksheets("Sheet2")
For i = 1 To 2
For Each cl In sh(i).Range("F1:J1")
If cl.Column Mod 2 = 0 Then
MsgBox sh(i).Name
sh(i).Range(sh(i).Cells(2, cl.Column), sh(i).Cells(12, cl.Column)).Copy
Worksheets("Sheet3").Cells(2, cl.Column).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationAdd
End If
Next
Next i
End Sub
Rangeの（）内でもシートの限定sh(i).は入れた方がよい。
実行結果
Sheet3　F-J列　２－１２行
30 41 52
30 41 52
30 41 52
30 41 52
30 41 52
30 41 52
30 41 52
30 41 52
30 41 52
30 41 52
30 41 52
２シート分計数が、各列で加算されている。
ーー
上記で、要修正点
●　("F1:J1")　　は　("F1:AD1")　　に
●　基データについて
　　Set sh(1) = Worksheets("Sheet1")
　　Set sh(2) = Worksheets("Sheet2"）
は、各々実際のデータのある、別々のブックのシート名に修正してください。
結果シートも修正のこと。

回答No.1

kkkkkm

Range("F25:F42")
は
Range(Cells(25,6),Cells(42,6))
と指定することができます。
構文は
Range(Cells(Row,Column),Cells(Row,Column))
なので列が変更されていくのでしたらColumnの部分をループ変数にすればループで処理ができます。

補足

ご教示いただいた内容を参考に、下記マクロを書いて実行してみましたが、
「オブジェクト定義のエラーです。」とエラーになってしまいました。
記述方法に誤り等ありましたら、ご指摘いただけるととてもうれしいです。。

Sub マクロ()

Dim i As Integer
For i = 6 To 30 Step 2

Dim xAdr As String
xAdr = "Cells(25, i), Cells(42, i)"

Dim buf As String
buf = Dir("C:某フォルダ\*あいう*.xlsm")
With Workbooks("貼り付け先ファイル.xlsm").Worksheets("貼り付け先シート")
Workbooks(buf).Worksheets("シート#1").Range(xAdr).Copy
.Range(xAdr).PasteSpecial Paste:=xlPasteValues

buf = Dir("C:\某フォルダ\*えお*.xlsm")
Workbooks(buf).Worksheets("シート#2").Range(xAdr).Copy
.Range(xAdr).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
End With
Next i

End Sub