1が6連続登場したらその行をコピーするＶＢＡマクロ

Question

私は、Ｅｘｃｅｌの「マクロの記録」で自動記述されたマクロを少々いじる程度しかできないスキルです。
行いたい処理がEXCEL ＶＢＡで実現できなくて困っています。どうぞお力を貸してください。

毎日、添付した画像の「上の表」のようなデータが出ます。
「下の表」は、二日後のデータに見立てています。このように、日ごとに列が増えていく表です。
（値の部分は、数値で0か1しか入りません。）
（上下に表を並べていますが、実際には「月初から本日まで」の１つの表しかありません。）

ここで、やりたいことは・・・
最後の日付から遡って6日間にわたり1が連続したら、その行だけ取り出して別シートにコピーしたいのです。
添付画像には、「すべての6連続した1」に黄色の網掛けをしていますが、
必要なのは「一番最後の日から遡って6日連続しているものだけ」です。

たとえば7/10の時点（上の表）では、工藤さんの行だけが該当。
7/12時点（下の表）では、石井さんだけが該当することになります。
該当した行を丸ごと、別のシートにコピーしたいわけです。

日によって、該当する行が複数行存在するときもあります。

自分で考えた限りでは、
データの右端（合計列）を見つけ、そこから左へ１セルだけオフセット→変数へセット
そこからさらに左へ5セルオフセット→変数へセット
それを選択範囲の開始セルと終了セルにできれば、
その中身がすべて１だった場合のみ、その行をコピーすればよいのでは・・・
と考えました。
行を１ずつ下に移動しながら最終行まで処理を続ける。
それを、行が終わるまで、繰り返す・・・（日によって行は増えたり減ったりする）
（データは0か1かしか入らないので、最終日から6日間を範囲選択している場合、全部１か？という判断をしてもよいし、足して６か？という判断でもよさそうです）

しかし、オフセットでセルはセレクトできても、
それを開始セル・終了セルとした「範囲」にすることができず、
また、行が終わるまで繰り返す処理も記述の仕方がわかりませんでした。

全く形になっていないので書く意味はなさそうですが、自分の記述を下記に示します。
繰り返し処理はネットで検索しました。
----------------------

Sub testMacro()
'
' testMacro Macro
'

Dim i As Long
Dim MaxRow　as Long

Range("A2").End(xlToRight).Select '2行目で、データの右端をセレクトする。変数にセットすべき？

Selection.Offset(0, -1).Select 'これが選択範囲の最初。変数にセットすべき？
Selection.Offset(0, -5).Select 'これが選択範囲の最後。変数にセットすべき？

Range(開始セル:終了セル).Select'この範囲指定がわからない

MaxRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row '最後の行を知る（どの列でもいい）

For i = 1 To MaxRow '１ずつ増やしながら最終行まで繰り返す

'範囲内が全部１かどうか（あるいは足して6かどうか）調べて、そうでなかったら次の行へ。
　　'もし全部1ならならコピーして別シートへコピー。

Next i

End Sub
----------------------

本当にまったく形になっていなくてすみません。
お力を貸していただけると嬉しいです
よろしくお願いします

eden3616 · Accepted Answer

No1のものです。
勉強のために解説するほどのものではないですが解説を書いてみました。
だいたい考え方はあっています。
実際の方法として要点ごとに以下のように解説致します。
不明な点があれば補足してください。

他サイト様ですが、
分かりやすい解説をされているサイトも参考でURLを載せておきます。

>該当した行を丸ごと、別のシートにコピーしたいわけです。

フォーマット（タイトル行や列幅等）を引き継ぐために
該当行をコピーではなく、シートをコピーしてから

ActiveSheet.Copy After:=ActiveSheet
Set mySt = ActiveSheet

不要行を削除する方法にしています。

Rows(i).Delete

>日によって、該当する行が複数行存在するときもあります。

全ての行に対して処理をしています。
行削除を行っているので若い行番号→最終行番号ですと
行削除した際に次の行番号が上にシフトしてしまい、
1個飛ばしになってしまうため、最終行から若い行（開始行）へ
Step値を-1として処理しています。

For i = .Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
　～
Next i
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_for_next.html

>データの右端（合計列）を見つけ、
>そこから左へ１セルだけオフセット→変数へセット

Findで「計」を検索し合計列の列番号を取得しています。
合計列の列番号から-1した値を最終日の列番号として利用します。

myCol = ActiveSheet.Rows(1).Find("計").Column - 1
http://www.moug.net/tech/exvba/0050116.html

>そこからさらに左へ5セルオフセット→変数へセット
>それを選択範囲の開始セルと終了セルにできれば、

セル範囲は『Range(開始セル,終了セル)』で指定できます。

.Range(.Cells(i, myCol - 5), .Cells(i, myCol))
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_cell.html
http://www.clayhouse.jp/vba/vba01.htm

>その中身がすべて１だった場合のみ、その行をコピー
>（あるいは足して6かどうか）

『WorksheetFunction.』+『関数名(引数)』で
エクセルのワークシート上で使用する関数を利用出来ます。
今回は『Sum』関数を使用し、引数に上記のセル範囲を設定しています。
Ifブロックで使用している『Not』は後に続く条件式が否定の場合に真となります。
よって、「対象範囲の合計値が6以外の場合に処理」となります。

If Not WorksheetFunction.Sum( _
　　　.Range(.Cells(i, myCol - 5), .Cells(i, myCol)) _
　　　) = 6 Then
　～
End If
http://www.excel-vba.net/excel-condition-001.html
http://home.att.ne.jp/zeta/gen/excel/c04p20.htm

eden3616 · Answer

各ブックから条件一致を別ブックへ集約するという事でしたら、
シートコピー　→　不要行削除では扱いにくいですね。

新規シート作成　→　条件一致行をコピーに変更しました。

以下の変更点となります。
（コード内の関連する箇所に該当番号をコメントしています）

(1)出力先の行数をカウントするcnt変数を追加
(2)6連続行の判定箇所で「Not」を削除
(3)ループ処理を最後から手前ではなく、開始から終了へ順送りに変更
(4)取得元と出力先のシートを配列変数（シートオブジェクト）に格納して処理

※）
補足の内容については質問の追加となり利用規約違反になりかねないため
この場での回答は控えさせていただきます。
不明な点があれば別途質問としてあげてください。

試行錯誤しながら、完成まで頑張ってください。

■変更VBAコード

Sub 判定コピー2()
'変数型宣言
Dim myCol As Long
Dim mySt(1) As Worksheet '(4)
Dim i As Long
Dim cnt As Long '(1)

'最終日取得
'（1行目の"計"を検索し、見つかった列-1を最終日の列番号とする）
myCol = ActiveSheet.Rows(1).Find("計").Column - 1

'コピー元シートを記憶 '(4)
Set mySt(0) = ActiveSheet

'シート新規作成 '(4)
'（コピー先のシートを作成）
Worksheets.Add After:=ActiveSheet
Set mySt(1) = ActiveSheet

'シート名設定
'（新規作成したコピー先のシート名を設定）
mySt(1).Name = "出力"

'行数分処理
With mySt(0)
　　For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row '(3)
　　　　If WorksheetFunction.Sum(.Range(.Cells(i, myCol - 5), .Cells(i, myCol))) = 6 Then '(2)
　　　　　　'最終日手前6セル分の合計が6以外であれば行コピー
　　　　　　cnt = cnt + 1 '(1)
　　　　　　.Rows(i).Copy mySt(1).Rows(cnt)
　　　　End If
　　Next i
End With
End Sub

eden3616 · Answer

シートを右クリック→コードの表示
または、Alt+F11でVBEを開き、標準モジュールを作成
してから最下のVBAコードを貼り付けてください。

コピー元のシートを表示した状態で、
表示→マクロ（または、Alt+F8）より「判定コピー」を選び「実行」してください。

表示中のシートの右側に「出力」という名前で新規シートが作成され、
該当の結果が表示されます。

注）
最終日の取得に『１行目』に存在する『「計」が入力されたセル』
の1つ手前の列を最終日の列として取得していますので、
「計」が見つからない場合はエラーとなります。

■VBAコード

Option Explicit

Sub 判定コピー()
'変数型宣言
Dim myCol As Long
Dim mySt As Worksheet
Dim i As Long

'最終日取得
'（1行目の"計"を検索し、見つかった列-1を最終日の列番号とする）
myCol = ActiveSheet.Rows(1).Find("計").Column - 1

'シート新規作成
'（コピー先のシートを作成）
ActiveSheet.Copy After:=ActiveSheet
Set mySt = ActiveSheet

'シート名設定
'（新規作成したコピー先のシート名を設定）
mySt.Name = "出力"

'行数分処理
With mySt
　　For i = .Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
　　　　If Not WorksheetFunction.Sum(.Range(.Cells(i, myCol - 5), .Cells(i, myCol))) = 6 Then
　　　　　　'最終日手前6セル分の合計が6以外であれば行削除
　　　　　　.Rows(i).Delete
　　　　End If
　　Next i
End With
End Sub

1が6連続登場したらその行をコピーするＶＢＡマクロ

No1のものです。

各ブックから条件一致を別ブックへ集約するという事でしたら、

シートを右クリック→コードの表示

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング