このようなVBAを作りたいのですが

質問

以下のようなデータがあります。
各セルの値は1～100までのランダムな値が入っています。
使用している列はAからFまでです。
例示すると、
A列　B列　C列　D列　E列　F列
1 　 　24 　 75 　　 69 　　 34 　　 2
55　　 66 　　47 　　28 　　92 　　53
13　　 21 　 63 　　 32 　　47 　　61
44 　 　3 　　 17 　　81 　　49 　　36
以下続く

ような形です。
そして、A列に1が200回出てきたら、そこまでのデータを（AからF列まで全てのデータ） を新たなシート１にコピーしたいのです。
この作業を繰り返したいのです。
次回　A列に１が400回出たところまでのデータを新たなシート２にコピー。
次々回　A列に１が600回 出たところまでのデータを新たなシート３にコピー。
｛続く｝
最終回　１が200の倍数丁度あるとは限らないので、空白になったら、そこまでのデータを新たなシートXにコピー。

といった感じです。
A列に1が何回出てくるかを基準に、データを分割するのが目的です。

言葉不足なので簡易化した例を挙げると、
１が２回出たら…という条件だとします。
A列　→新シート１のA列　　新シート２のA列　　新シート３のA列　
２　　　　　　２　　　　　　　　　　６　　　　　　　　　　　２
１　　　　　　１　　　　　　　　　　７　　　　　　　　　　　１
３　　　　　　３　　　　　　　　　　１
１　　　　　　１　　　　　　　　　　８　
６　　　　　　　　　　　　　　　　　５
７　　　　　　　　　　　　　　　　　１
１
８
５
１
２
１

のようにデータを分割したいのです。
普段、マクロを使ってデータから数値を取ることはするのですが、ある一定の範囲を新たなシートにコピーといった作業はしたことがないので、どのようなVBAを書けばいいのか見当がつきません。
分かる方、お手数をおかけして申し訳ないのですが、よろしくお願いします。

回答No.3

Wendy02 · ベストアンサー

こんにちは。

>新たなシートにコピーといった作業はしたことがないので、
>新シート１のA列　　新シート２のA列　　新シート３のA列　

私には、"新シート1" とかいう設定自体が新たな名前をつけると解釈しました。新たなブックに移すにしても、そんなに手間ではないと思います。

仕組みを簡単に説明すると、1で、オートフィルタを掛けて、勘定して、セルの行番号を記録していけば数えるのは難しくありません。数万行でも、たぶん数秒で終わってしまうと思います。

一応、コピーした行数と、1の数だけは確認しました。

'標準モジュール

Sub NumbersCopy()
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Dim myRow As Long
　　Dim LastRow As Long
　　Dim c As Variant
　　Dim s As Integer
　　Dim cnt As Integer
　　Dim flg As Boolean
　　Dim shtCnt As Integer
　　Dim adrs() As Long
　　Dim acSheet As Worksheet
　　'設定
　　Const UNIT As Integer = 200 '区切り単位
　　Const SHNAME As String = "新シート" 'シート名/ただし、：, などは使えません

　　shtCnt = Worksheets.Count
　　Set acSheet = ActiveSheet
　　'オートフィルタはしていないことを条件とします。
　　If acSheet.AutoFilterMode Then acSheet.AutoFilterMode = False

　　'１を数える
　　With acSheet
　　　　If .Range("A1").Value = 1 Then
　　　　　　.Rows(1).Insert
　　　　　　.Range("A1").Value = "Dum"
　　　　　　flg = True
　　　　End If
　　　　'最終行を求める(挿入後）
　　　　LastRow = .Range("A65536").End(xlUp).Row

　　　　With .Range("A1", .Range("A65536").End(xlUp))
　　　　　　.AutoFilter Field:=1, Criteria1:="1"
　　　　　　For Each c In .SpecialCells(xlCellTypeVisible)
　　　　　　　　ReDim Preserve adrs(i)
　　　　　　　　adrs(i) = c.Row
　　　　　　　　i = i + 1
　　　　　　Next c
　　　　　　.AutoFilter
　　　　End With
　　End With

　　'シートを予め作る
　　cnt = Int((UBound(adrs()) + 1) / UNIT)
　　'余りが出ている場合
　　If LastRow > adrs(UBound(adrs())) Then cnt = cnt + 1

　　Worksheets.Add after:=Worksheets(shtCnt), Count:=cnt
　　For s = shtCnt + 1 To Worksheets.Count
　　　 Worksheets(s).Name = SHNAME & CStr(s - shtCnt)
　　Next s

　　'初期値
　　If flg Then
　　　k = 2
　　Else
　　　k = 1
　　End If
　　Do
　　　　j = j + UNIT
　　　　shtCnt = shtCnt + 1
　　　　If j > UBound(adrs) + 1 Then
　　　　　With Worksheets(shtCnt)
　　　　　　acSheet.Rows(k & ":" & LastRow).Copy .Range("A1")
　　　　　End With
　　　　Else
　　　　　　myRow = adrs(j)
　　　　With Worksheets(shtCnt)
　　　　　　'Fまで
　　　　　　acSheet.Rows(k & ":" & myRow).Resize(, 6).Copy .Range("A1")
　　　　End With
　　　　End If
　　　　k = myRow + 1

　　Loop While Worksheets.Count >= shtCnt + 1

　 If flg Then
　　 acSheet.Rows(1).Delete
　 End If
　 Set acSheet = Nothing
End Sub

お礼

非常に丁寧なプログラムをありがとうございます！
Wendy02さんがお書きくださった内容を理解し、いずれは自分で作れるようになりたいと思います。
お手数をおかけして申し訳ございません。
そして、本当にありがとうございました！

回答No.2

misatoanna

> 各セルの値は1～100までのランダムな値が入って「います」。

つまり、都度入力される数字で判断するのではなく、既に全体が入力
済みのシートに対して処理するということで解釈しました。

とりあえず、簡易化された表(１が２回出たら)の場合です。
200回の場合は、★の行を　If cnt = 200 Then　に書き換えるわけで
すが、200ともなると、テストデータ作成とマクロ実行後の結果のチェ
ックが大変なので、検証していません。

Sub Test()
　Dim sh As String, i As Integer, rw As Integer, cnt As Integer
　Application.ScreenUpdating = False
　sh = ActiveSheet.Name
　i = 1
　rw = 1
　Do While Sheets(sh).Cells(i, 1) <> ""
　　If Sheets(sh).Cells(i, 1) = 1 Then cnt = cnt + 1
　　If cnt = 2 Then　　　　　'★
　　　Sheets.Add Type:="ワークシート"
　　　ActiveSheet.Name = "Until " & i
　　　ActiveSheet.Move after:=Sheets(Sheets.Count)
　　　Sheets(sh).Rows(rw & ":" & i).Copy _
　　　　　Destination:=Sheets("Until " & i).Rows(1)
　　　rw = i + 1
　　　cnt = 0
　　End If
　　i = i + 1
　Loop
　Sheets.Add Type:="ワークシート"
　ActiveSheet.Name = "Until " & i
　ActiveSheet.Move after:=Sheets(Sheets.Count)
　Sheets(sh).Rows(rw & ":" & i).Copy _
　　　　Destination:=Sheets("Until " & i).Rows(1)
　Application.ScreenUpdating = True
End Sub

お礼

素晴らしいプログラムありがとうございます！
まだまだVBA初心者なので全くアイデアが浮かびませんでした。
本当に助かります！
misatoannaさんのプログラムを見てどのような構造になっているか理解し、更にVBAを勉強したいと思います。
改めて，ありがとうございました！

回答No.1

imogasi

質問では１が所定回数加わると、初めからのデータを別シートへ写すような表現になっている。実例では前回移した以後のこれまでのデータになっている。たぶん実例の方だろう。
ーー
これはA列に１が所定回数入力されたら、すぐに所望の処理をするのを希望ですか。
こんな、回答者にパズルを解かす（本質問は課題の丸投げタイプですよ）ような方式をやめて、データが全部入力し終わったら、処理する（バッチ処理）か、A列で 所定回数だけ１が現れたら、（COUNTIF関数でセルに１の件数をだし、気づいて）、処理のコマンドボタンを押すとかが良いのではないですか。処理が重くなったりチェンジイベントは扱いにくいと思うが。