Excelの改行について

あるシートの中に複数のデータが存在します。
特定のキーワードをもとに1シートにまとまったデータを複数のシートに分割したいと思います。

（例）
要素A
・・・
データ5
データ6
データ7

要素B
データ1
データ2
データ3

要素C
・・・
データ16
データ17
データ18

つまり「要素」というキーワードで開始行はわかるのですが、データ数が要素によって異なるので、一概に100データずつ区切るのようなことは不可能です。
「要素A」を含む行から「要素B」直前行までを一つのシートにして、要素分だけシートを作りたいと思います。

どのようなマクロを組めばよいでしょうか。
何方様かご教授願います。

No.6 ベストアンサー 回答者： mt2008 回答日時： 2013/06/12 20:20

う～ん、必ず「要素」がある1行目から始めるようになっているからnRowがEmptyにはならない筈だったんですけどね。

ひょっとして「要素」を含んでいるけど「要素」では始まらない行があるんですかね。
だとしても違ったエラーになるはずなんですが……。

コードを以下のように変更してみて下さい。
If Left(vData, 2) = "要素" Then
↓
If InStr(vData, "要素") > 0 Then

No.5 回答者： mt2008 回答日時： 2013/06/12 12:55

ANo.2、ANo.4です

> 実行してみると「インデックスが有効な範囲にありません」と”Sheets(2).Cells(nRow, nCol) = vData”に対してエラーになってしまいます。

もしかして、シートは1枚しかないブックですか？
でしたら、空のシートを一枚最後尾に追加してからマクロを動かしてみて下さい。

この回答への補足

ありがとうございます。
空シートを加えてみたのですが同じエラーが出てしまいます…。
デバッグでウォッチしてみると「nRow」がEmpty値になっていますがこのままで宜しいのでしょうか？

補足日時：2013/06/12 16:32

No.4 回答者： mt2008 回答日時： 2013/06/11 22:33

ANo.2です。

> 今回は各シートに分けるという事でお願いしたのですが、同シート内で要素を空白列を設けて配置することは可能でしょうか？

こっちの方がはるかに簡単ですよ。
自シートのデータを書き換えるのは嫌だったので、Sheet2に要素毎に横に並べたものを作るようにしました。

Sub Sample2()
　　nLast = Cells(Rows.Count, 1).End(xlUp).Row
　　nStart = Columns("A:A").Find(What:="要素", After:=Cells(nLast, 1)).Row
　　nCol = -1
　　For i = nStart To nLast
　　　　vData = Cells(i, 1)
　　　　If Left(vData, 2) = "要素" Then
　　　　　　nCol = nCol + 2
　　　　　　nRow = 1
　　　　End If
　　　　Sheets(2).Cells(nRow, nCol) = vData
　　　　nRow = nRow + 1
　　Next i
End Sub

この回答への補足

早速ありがとうございます。

実行してみると「インデックスが有効な範囲にありません」と”Sheets(2).Cells(nRow, nCol) = vData”に対してエラーになってしまいます。

どこを修正すれば良いのでしょうか…。

補足日時：2013/06/11 23:46

No.3 回答者： tsubuyuki 回答日時： 2013/06/07 07:29

不確定要素があるので、完全な回答とは言えません。

質問文中にあるとおり、区切るキーワードが全て「要素*」であること、
これらデータが全てＡ列にあることが条件で組んであります。

Sub sample()
Dim MaxRow As Long, TagRow As Long, i As Long
Dim OldSheet As Worksheet, NewSheet As Worksheet

　　　　Set OldSheet = Sheets("Sheet1")
　　　　MaxRow = OldSheet.Cells(OldSheet.Rows.Count, 1).End(xlUp).Row
　　　　TagRow = MaxRow
　　　　For i = MaxRow To 1 Step -1
　　　　　　　　If OldSheet.Cells(i, 1) Like "要素*" Then
　　　　　　　　　　　　Set NewSheet = Worksheets.Add()
　　　　　　　　　　　　NewSheet.Name = OldSheet.Cells(i, 1)
　　　　　　　　　　　　OldSheet.Rows(i & ":" & TagRow).Copy NewSheet.Range("A1")
　　　　　　　　　　　　TagRow = i - 1
　　　　　　　　End If
　　　　Next i
End Sub

これで十分出来ます。

質問文からは読み取ることがどうしても出来なかった条件として、
・どの列をどれだけ持っていけば良いのかわからないので、行全体をコピーしています。
・コピー先のブックの指定もありませんので、同一ブックの先頭に新規シートを挿入しています。
・コピー元のブックに関しても削除や修正などの考慮はしていません。
などなどが挙げられます。

その他に何か「質問文中に無い条件」があるとすると、
コレだけでは思い通りには動きませんのでご注意下さい。

この回答への補足

ご回答ありがとうございます！

すみません！質問文には書いておりませんでしたがそれぞれの要素は、列数は4列で構成されます。
行数は要素によって異なるので不定数です。
つまり生データでは「要素＊」で始まる＊行4列のデータセットが＊個、1シートに存在しています。
これをデータセットごとに再配置したいということなのです。

補足日時：2013/06/11 19:50

No.2 回答者： mt2008 回答日時： 2013/06/06 17:11

A列にある「要素…」を探して処理するようにしました。

あくまでサンプルですので、エラー処理等は含めていません。悪しからず。

Sub Sample()
　　Dim nRow()
　　nLast = Cells(Rows.Count, 1).End(xlUp).Row
　　nCount = WorksheetFunction.CountIf(Range("A:A"), "要素*")
　　If nCount < 2 Then Exit Sub '「要素」の数が2未満ならシートを作る必要なし
　　ReDim nRow(nCount)
　　nRow(nCount) = nLast + 1
　　nRow(0) = Columns("A:A").Find(What:="要素", After:=Cells(nLast, 1)).Row
　　For i = 2 To nCount
　　　　 nRow(i - 1) = Columns("A:A").FindNext(After:=Cells(nRow(i - 2), 1)).Row
　　Next i
　　’新規シート作成
　　sShtName = ActiveSheet.Name
　　For j = 1 To nCount
　　　　Call fMkSheet(sShtName, nRow(j - 1), nRow(j) - 1)
　　Next j
　　Worksheets(sShtName).Select
End Sub
Sub fMkSheet(aName, aRow1, aRow2)
　　Worksheets(aName).Rows(aRow1 & ":" & aRow2).Copy
　　Sheets.Add After:=Sheets(Sheets.Count)
　　ActiveSheet.Paste
End Sub

この回答への補足

お礼、遅くなりましてすみませんでした。mt2008さんのマクロで目的の動作は実行できました！ありがとうございました(><)

さらにお願いがあるのですが、
今回は各シートに分けるという事でお願いしたのですが、同シート内で要素を空白列を設けて配置することは可能でしょうか？

（例）
要素A　　[空白列]　　要素B　　[空白列]　　要素C
・・・　　　□　　　 データ1　　 □　 　　・・・
データ5　　 □ 　　　データ2　　 □　　　 データ16
データ6　　 □ 　　　データ3　　 □　　　 データ17
データ7　　 □　　　 データ4　　 □　　　 データ18

更にご教授願います！

補足日時：2013/06/11 19:37

No.1 回答者： cj_mover 回答日時： 2013/06/06 16:24

こんにちは。

こちらの理解が至っていない部分もあるでしょうけれど、
想定できるものを拡張解釈して動くものを書きました。
そちらで、修正が難しいようでしたらば、補足欄などを使って
相談してみてください。

追加するシートの数が多過ぎる場合は、他の方法を考えた方がいいので、
そうと解れば改めて着手します。

　　ex.)
　分割する各セクションの参照文字列を作ります。
　　 "A1:E5,A7:E10,A11:A14"
　作成した参照文字列を基にセル範囲を取得します。
　　Range("A1:E5,A7:E10,A11:A14")
　セル範囲を領域毎にコピーします。
　　Range("A1:E5,A7:E10,A11:A14").Areas(i).Copy

後は基本技術の応用だけです。

Sub Re8121992()
　　Const SRCCOL As Long = 1　　' ■　要指定、元データの検索対象列位置　■仮にＡ列
　　Dim sRECol As String　　' 最終列の参照文字列（":E"とか":RC"とか）
　　Dim sRef As String　　' セクション毎の参照文字列（カンマ区切り）
　　Dim nBtm As Long　　' 元データの最下行
　　Dim nABtm As Long　　' セクション毎の最下行（フラグ）
　　Dim tnAddSh As Long　　' 追加するシート数＝セクション数
　　Dim nIdxSrcSh As Long　　' 元データシートのインデックス
　　Dim i As Long

　　Application.ScreenUpdating = False
　　With Sheets("Sheet1")　　' ■　要指定、元データ、シート名　■仮に"Sheet1"
　　　　With .UsedRange
　　　　　　nBtm = .Row + .Rows.Count - 1　　' 元データの最下行
　　　　　　sRECol = ":" & Split(.Columns(.Columns.Count).Address, "$")(3)　　' 最終列の参照文字列（":E"とか":RC"とか）
　　　　End With
　　　　For i = nBtm To 1 Step -1
　　　　　　If nABtm Then　　' セクション毎の最下行（フラグ）
　　　　　　　　If .Cells(i, SRCCOL) Like "要素*" Then　　' セル値が"要素*"で始まるなら
　　　　　　　　　　sRef = ",A" & i & sRECol & nABtm & sRef　　' セクション毎の参照文字列（カンマ区切り）
　　　　　　　　　　nABtm = Empty
　　　　　　　　End If
　　　　　　ElseIf .Cells(i, SRCCOL) <> "" Then
　　　　　　　　nABtm = i　　' セクション毎の最下行
　　　　　　End If
　　　　Next i
　　　　nIdxSrcSh = .Index　　' 元データシートのインデックス
　　　　tnAddSh = UBound(Split(sRef, ","))　　' 追加するシート数＝セクション数
　　　　If tnAddSh < 2 Then Exit Sub　　' 追加の必要なければ抜ける
　　　　Worksheets.Add After:=ActiveSheet, Count:=tnAddSh　　' シート数に応じてシート追加
　　　　With .Range(Mid$(sRef, 2))　　' セクション毎に分けてあるセル範囲を纏めて取得
　　　　　　For i = 1 To tnAddSh
　　　　　　　　Sheets(nIdxSrcSh + i).Name = .Areas(i).Cells(1)　　' シート名変更
　　　　　　　　.Areas(i).Copy　　' 元データ、セクション毎（指定したセル範囲の領域毎）にCopy
　　　　　　　　With Sheets(nIdxSrcSh + i)　　' 対応したシートの
　　　　　　　　　　With .Cells(1)　　' セルA1に
　　　　　　　　　　　　.PasteSpecial Paste:=xlPasteColumnWidths　　 ' 列幅を貼付け
　　　　　　　　　　　　.PasteSpecial Paste:=xlPasteAll　　' すべて貼付け
　　　　　　　　　　End With
　　　　　　　　End With
　　　　　　Next i
　　　　End With
　　End With　　'　　With Sheets("Sheet1")
　　Application.CutCopyMode = False
End Sub

この回答へのお礼

ご回答ありがとうございます！
今回はmt2008さんのマクロを採用させて頂きました。
さらに同シート上にデータセットを再配置することができるマクロがあればご教授願います！

お礼日時：2013/06/11 19:52