みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

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

解決済みの質問

エクセルVBA セル範囲の選択とループ処理

VBA歴がまだ浅い学習者です。アドバイスをお願いいたします。

4つのシート、D、X、Y、Summaryがあります。

シートの概要:
D:データが大量にあるシート
X、Y:個別にデータを張り付けるシート
Summary:X、Yを元にシート関数で、結果を出すシート

シートDの概要:

ABCDEFGHIJKLM
空空空空空空空空空空空空空 ←1行目は空白
空空11111111111 ←データの最初の行は、A列B列のみ空白、
1111111111111
1111111111111 1つ目のデータ群(A2:M14) ※行数は適当、列は固定(A:M)
1111111111111
空空22222222222
2222222222222 2つ目のデータ群 (A15:M23) ※行数は適当、列は固定(A:M)
2222222222222
2222222222222
空空33333333333
3333333333333
      ・      
      ・      
      ・      
      ・      
空空nnnnnnnnnnn ←データの数は可変する(ただし偶数個)
nnnnnnnnnnnnn
nnnnnnnnnnnnn
nnnnnnnnnnnnn
nnnnnnnnnnnnn

◇注意点 データの列数は同一ですが、行数は、同じではありません。
1つ目と2つ目、3つ目と4つ目・・・のデータ群が、比較したいペアのデータです。

やりたい操作:(下記にサンプルコードあり)
・1つ目のデータ群を選択してコピー
・それをシートXのA1より貼り付け
・2つ目のデータ群を選択してコピー
・それをシートYのA1より貼り付け
・(ここで比較結果が、シートSummaryのB2:J2に返される)
・シートSummaryのB2:J2に返された結果をコピーして、同シート、B4より貼り付ける(以後その下に張り付ける)
・3つ目のデータ群を選択してコピー
・それをシートXのA1より貼り付け
・4つ目のデータ群を選択してコピー
・それをシートYのA1より貼り付け
・(ここで比較結果が、シートSummaryのB2:J2に返される)
・シートSummaryのB2:J2に返された結果をコピーして、同シート、B5より貼り付ける(以後その下に張り付ける)
・以下データがなくなるまでループ

わからない点:
・データ群のセル範囲を手書きではなく自動(おそらくend(xldown)を使用)で選択させる記述
 ※データの見出し行にあるAB列の空白をうまく使って書けるのではと考えています。
・ループ処理の記述

どうかご教授お願いいたします。
補足が足りない場合は、お伝えください。

サンプルコード

Sub テスト()
Sheets("D").Select
Range("A2:M14").Select  ’???
Selection.Copy
Sheets("X").Select
ActiveSheet.Paste
Sheets("D").Select
Range("A15:M23").Select '???
Application.CutCopyMode = False
Selection.Copy
Sheets("Y").Select
ActiveSheet.Paste
Sheets("summary").Select
Range("B2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Range("B4").Select '???
ActiveSheet.Paste
End Sub

投稿日時 - 2015-04-03 13:45:07

QNo.8948349

困ってます

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

 確認したい事があります。
 シートSummaryには以前結果を出力した際のデータが残っている場合もあり得ると思うのですが、その様な場合においても、シートDの内容が更新された後であれば、シートSummaryに残っている古いデータは消去してしまっても構わないのでしょうか?
 もしそれで宜しければ、次の様なマクロは如何でしょうか。


Sub QNoq8948349_エクセルVBA_セル範囲の選択とループ処理()

Dim i, LastR, TopR, BottomR, myRow As Long
Dim SheetD, SheetX, SheetY, SheetSu, mySheet As Worksheet
Dim ColumnF, ColumnL As String
Dim ResultRange As Range

Application.ScreenUpdating = False '(処理が終わるまで)画面に現れる表示内容の更新を行わない

Set SheetD = Sheets("D") '元データが入力されているシート
Set SheetX = Sheets("X") '奇数個目のデータのグループを貼り付けるシート
Set SheetY = Sheets("Y") '偶数個目のデータのグループを貼り付けるシート
Set SheetSu = Sheets("Summary") '結果を出力するシート
Set ResultRange = SheetSu.Range("B2:J2") '一時的な結果が表示されるセル範囲
ColumnF = "A" 'コピー範囲の最初の列
ColumnL = "M" 'コピー範囲の最後の列
LastR = SheetD.Range(ColumnF & Rows.Count).End(xlUp).Row 'コピー範囲の最後の行の行番号を取得
myRow = 0

ResultRange.Offset(1).Resize(Rows.Count _
- ResultRange.Row, ResultRange.Columns.Count).ClearContents
'↑以前に記録された古い結果を消去
TopR = 2 'コピーするセル範囲の内の一番上の行

'↓「コピーするセル範囲の内の一番上の行」として指定された行が、最終行よりも上の行である限り、処理を繰り返す
Do While TopR < LastR
For i = 0 To 1
With SheetD
TopR = .Range(ColumnF & TopR).End(xlDown).Row 'コピーするセル範囲の内の一番上の行
BottomR = .Range(ColumnF & TopR).End(xlDown).Row 'コピーするセル範囲の内の一番下の行
End With
Select Case i
Case Is = 0 'iの値が0の場合は貼り付け先のシートにSheetXを指定
Set mySheet = SheetX
Case Is = 1 'iの値が0の場合は貼り付け先のシートにSheetYを指定
Set mySheet = SheetY
End Select
mySheet.Columns(ColumnF & ":" & ColumnL).ClearContents '貼り付け先のシートの古いデータを消去
SheetD.Range(ColumnF & TopR & ":" & ColumnL & BottomR).Copy
'↑コピー元のシートの中から、データの塊を1つコピー
mySheet.Range("A1").PasteSpecial Paste:=xlPasteValues '貼り付け先のシートにコピーしたデータを貼り付け
TopR = BottomR + 1 '次のTopRの行番号を求めるための下準備として、次の空欄の行を指定
Next i
myRow = myRow + 1 'ResultRangeで指定されたセル範囲の何行下に結果を貼り付けるのかを示す数値
ResultRange.Offset(myRow).Value = ResultRange.Value 'ResultRangeに表示されている結果を、その下の行に貼り付け
Loop '繰り返し行う処理はここまで

Application.CutCopyMode = False 'コピーモードの解除
SheetX.Columns(ColumnF & ":" & ColumnL).ClearContents '不要になったSheetXのデータを消去
SheetY.Columns(ColumnF & ":" & ColumnL).ClearContents '不要になったSheetYのデータを消去
Application.ScreenUpdating = True '画面に現れる表示内容の更新を行うモードに戻す

End Sub

投稿日時 - 2015-04-03 18:05:30

お礼

大変感謝いたします。
見事きれいに実行することができました。

また、書き方、組み立て順序など、非常に勉強になりました。
何度も見直しをしつつ、今後の勉強の参考にさせていただきます。
ありがとうございました。


>>シートSummaryには以前結果を出力した際のデータが残っている場合もあり得ると思うのですが、その様な場合においても、シートDの内容が更新された後であれば、シートSummaryに残っている古いデータは消去してしまっても構わないのでしょうか?
 
シートX,Yのことかと存じます。おっしゃる通り、データ行数が可変のため、一旦消去する必要がございました。ご留意くださりありがとうございました。

投稿日時 - 2015-04-03 22:49:22

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

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

回答(2)

ANo.1

VBAを書ける方のようなので、ざっとした発想から。

たぶんこれよりかっこよく書く方法はありますけど、VBAのコードは
「後で見てメンテナンス出来ない」と困りますから、コードが長くなっても
可能な限り「わかりやすい」ことが肝要だ、と私は思っているので。

で、ですね。まずは空欄を探す方法。要はIF文で""を見つければ
いいんです。

Cells(開始行,1).Select
Do Until Selection.Value=""
Selection.Offset(1).select
Loop
終了行=Selection.Row

これで、開始行、終了行が得られます。あとは

Range(Cells(開始行, 1), Cells(終了行, 13)).Select

でコピー範囲が得られます。コピーが終われば

開始行=終了行+1

で、さっきのループを回せばオッケーです。

投稿日時 - 2015-04-03 14:16:14

お礼

ありがとうございます。
無事に解決することができました。

わかりやすい文字列をコード内で使うとたしかに、のちのち見やすいですね。
今後も、見直しをしながら、回答者さんのようなわかりやすいコードをかけるようになるよう、頑張ってまいります。

投稿日時 - 2015-04-03 22:54:11

あなたにオススメの質問