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

解決済みの質問

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

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

F列~AD列の間で、1列おきに下記処理を行う
「あいう」の指定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

投稿日時 - 2019-11-19 17:16:33

QNo.9680764

困ってます

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

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も忘れずに。

投稿日時 - 2019-11-19 20:58:24

お礼

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

投稿日時 - 2019-11-20 14:34:53

ANo.2

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

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

回答(5)

ANo.5

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

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

投稿日時 - 2019-11-20 08:28:06

ANo.4

コピー貼り付けだと遅い感じがしたのでコピー貼り付けじゃないモードで
貼り付け先ファイルに加算していきます。画面表示を止めていますので終了までセルの値は変化しません。
もしエラーで止まった場合
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

投稿日時 - 2019-11-19 23:08:13

ANo.3

Workbookの課題を、テストデータ作成が手数なので、
同一WorkbookのSheet1とSheet2の課題に変えてやってみました。
参考になれば。
また「F列~AD列の間」という条件を、F~J列3列に少なくしました。
これは原案に変更が簡単ですが。
ーーー
例データ
Sheet1 F-J列 2-12行
101112
101112
101112
101112
101112
101112
101112
101112
101112
101112
101112
Sheet2 F-J列 2-12行
203040
203040
203040
203040
203040
203040
203040
203040
203040
203040
203040
標準モジュールに
コード
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列 2-12行
304152
304152
304152
304152
304152
304152
304152
304152
304152
304152
304152
2シート分計数が、各列で加算されている。
ーー
上記で、要修正点
● ("F1:J1")  は ("F1:AD1")  に
● 基データについて
  Set sh(1) = Worksheets("Sheet1")
  Set sh(2) = Worksheets("Sheet2")
は、各々実際のデータのある、別々のブックのシート名に修正してください。
結果シートも修正のこと。

投稿日時 - 2019-11-19 21:55:29

ANo.1

Range("F25:F42")

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

投稿日時 - 2019-11-19 17:47:58

補足

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


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

投稿日時 - 2019-11-19 18:27:58

あなたにオススメの質問