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

質問

私は、Ｅｘｃｅｌの「マクロの記録」で自動記述されたマクロを少々いじる程度しかできないスキルです。
行いたい処理が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
----------------------

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

回答No.2

eden3616 · ベストアンサー

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

お礼

回答ありがとうございます。
Findの活用や　If Notをつかった条件判断と繰り返し、大変参考になります。
また、丁寧な解説も入れてくださり、初心者として大変助かります!(^^)!

実はこの質問、作りたい全体プログラムの、もっとも難しい１部分についてアドバイスをいただこうと思ってのもので、実際にはさらにいろいろな処理を続けていく必要があります。
（なんだか、全部を丸投げするのって反則のような気がしまして・・・）

今回の回答をいただけて、びっくりするほどVBA構築のめどが立ってきました！！(^^)/
まだまだ難関はありますけれど～(´・ω・｀)

↓↓↓　　完成目標は…こうです！　　↓↓↓

今回の元データはチーム１.xlsブックのデータである。
ほかにもチーム２.xls、チーム３.xlsなど、10ファイルほどある。
既存の「連続6個.xls」というブックがあり、プログラムはその標準モジュールに記述する
連続6個.xlsは、チーム１.xlsを開いて、今回教えていただいたプログラムを実行する。
出力シートに抽出された6連続１のデータ行は、「連続6個.xls」の最終行にコピーされる。
この時、A列に入っていた人の名前を、ブック名と同じチーム１にする。（複数行あっても。）
続いてチーム２.xlsを開き、同処理実行。抽出されたデータは、「連続6個.xls」の最終行にさらにコピーされていく。A列はチーム２とする。
（出力シートに抽出された時点で、A列の全セルにブック名を入れておくべきですね♪
この時、書いて下さった処理構文
.Range(.Cells(i, myCol - 5), .Cells(i, myCol))
に近いものが使えそうです♪）

連続6個.xlsブックは、

チーム１　　1　0　1　1　1　1　1　1　1　1
チーム１　　1　0　1　0　1　1　1　1　1　1
チーム１　　1　0　1　1　1　1　1　1　1　1
チーム２　　0　0　0　0　1　1　1　1　1　1
チーム３　　1　1　1　0　1　1　1　1　1　1
......

みたいな感じになるでしょう。

チーム１、チーム２、チーム３・・・という風に複数ブックを開いては処理して閉じる、をしていくので、
変数にブック名を配列としてチーム１、チーム２、チーム３…という風に入れて、
forで繰り返す時にブック名が入れ替わるようにできたらいいですよね♪
これもかなりの難関っぽいですねー　( ;∀;)
でもたぶん、これも教えていただいた
With ～　End With　のところを活かしつつ、工夫する感じでしょうか～( *´艸｀)

↑↑↑　　完成目標は…こうです！　　↑↑↑

目標はこんな感じです♪前途多難ですネ（笑）
でも、本当に今回教えていただいた構文からの発展が見込めます。
大変うれしいです。(^^♪

もし、またどこかで躓いたら、似たような質問を載せると思います。
その時はまたぜひ、ご協力よろしくお願いします！！！（笑）
頑張ります、ありがとうございました！　m(__)m

回答No.3

eden3616

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

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

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

(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

お礼

ありがとうございます～～(^з^)-☆
まさか変更版を書いていただけるとは思っていませんでした！(*^^*)

これでいよいよ完成に近づける気がします。
各処理の仕組みや意味が良く理解できましたので、今後にも役立てられる気がします。
どうもありがとうございました～～(*^^*)

もしこれに関する別の質問を目にされたときは、またぜひ助けていただきたいです(笑)
がんばります(*^^*)

回答No.1

eden3616

シートを右クリック→コードの表示
または、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

お礼

回答ありがとうございます～～～(^^)/

美しいプログラムですね！！

.Range(.Cells(i, myCol - 5), .Cells(i, myCol)))
のところとか、初心者がネットで解説を見た程度ではなかなか構成できないところですね～～

大変助かります。ありがとうございます(^_-)-☆