マクロの修正をお願いします

質問

前回と前々回の質問で、マクロを作成していただき
とても作業が楽になったのですが、一部変更してもらいたい点があり
再度質問させていただきます（何度も申し訳ありません）
自分でなんとかできないかと思ったのですが、どうにもできず・・すみません。

前回の質問へのリンク：http://okwave.jp/qa4383630.html

D列から抽出した数値を、E～Qに書き出すように作成していただきました。
この書き出し先を「A列に数字が入っている行のE～Q」に変更していただきたいです。
(A1に数字が入っていたら、E1～Q1に書き出すようなかたち)
A列には数行置きに数字が入っております。数字は全て半角英数です。
数字以外は、全て空欄のセルです（A1に数字、A2～A5まで空欄、A6に数字というような感じです）

本当に何度も申し訳ないのですが、急ぎませんので修正できる方がいらっしゃいましたらお願いします。

前回の質問で作成していただいたマクロはこちらです。
Sub　test()
　Dim　RegExp　As　Object
　Dim　r　As　Range
　Dim　rr　As　Range,　rs　As　Range
　Dim　i　As　Integer,　j　As　Integer
　Dim　match,　v
　ReDim　v(1　To　1,　1　To　6)

　Set　RegExp　=　CreateObject("VBScript.Regexp")
　RegExp.Pattern　=　"\d+"
　RegExp.Global　=　True

　i　=　7
　For　Each　r　In　Range("D1",　Cells(Rows.Count,　4).End(xlUp))
　　　　　If　InStr(r.Value,　"(")　And　rr　Is　Nothing　Then
　　　　　　　　Set　rr　=　r.Resize(3)
　　　　　　　　　　　　For　j　=　1　To　3
　　　　　　　　　　　　　　　　v(1,　j)　=　Split(Replace(rr.Item(j).Value,　")",　""),　"(")(0)
　　　　　　　　　　　　　　　　v(1,　j　+　3)　=　Split(Replace(rr.Item(j).Value,　")",　""),　"(")(1)
　　　　　　　　　　　　Next
　　　　　　　　　　　　rr.Item(1).Offset(,　1).Resize(,　6).Value　=　v
　　　　　　　　　　　　ReDim　v(1　To　1,　1　To　6)

　　　　　　　　　　　　With　rr.Resize(1).Offset(3)
　　　　　　　　　　　　　　　　　If　RegExp.test(.Value)　Then
　　　　　　　　　　　　　　　　　　　　For　Each　match　In　RegExp.Execute(.Value)
　　　　　　　　　　　　　　　　　　　　　　　　rr.Item(1).Offset(,　i).Value　=　match.Value
　　　　　　　　　　　　　　　　　　　　　　　　i　=　i　+　1
　　　　　　　　　　　　　　　　　　　　Next
　　　　　　　　　　　　　　　　　End　If
　　　　　　　　　　　　End　With
　　　　　ElseIf　LenB(r.Value)　<　1　Then
　　　　　　　　Set　rr　=　Nothing
　　　　　　　　i　=　7
　　　　　End　If
　Next
　Set　RegExp　=　Nothing
　Set　rr　=　Nothing
　Erase　v
End　Sub

回答No.17

n-jun · ベストアンサー

ANo.15です。

補足事項のコードは、
Sub kesu()

Range("A1", Cells(Rows.Count, 4).End(xlUp).Offset(, -3)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("D:D").Delete Shift:=xlToLeft

End Sub
これかな？

お礼

毎回迅速な対応ありがとうございます。
希望通りの動きでした。
前々回から長々とつきあわせてしまい、本当に申し訳ありませんでした。
あきれずに対処していただけて、本当に感謝しております。

ご協力いただけた皆様に良回答をつけたいのですが
良回答と次点の2名しか選べませんので、申し訳ありませんが今回のようにさせて頂きました。

皆様本当に本当に、どうもありがとうございました！！

回答No.16

xls88

これでどうでしょうか。

Sub test4()
　　Dim r As Range
　　Dim rr As Range
　　Dim ra As Range
　　Dim rd As Range
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Dim v(1 To 13) As Variant

　　Set rr = Range("A1", Cells(Rows.Count, "A").End(xlUp))
　　Set rr = rr.SpecialCells(xlCellTypeConstants, 1)
　　For Each r In Range("D1", Cells(Rows.Count, "D").End(xlUp))
　　　　If InStr(r.Value, "(") <> 0 And InStr(r.Value, ")") <> 0 Then
　　　　　　i = i + 1
　　　　　　If i = 1 Then Set ra = rr.Areas(k + 1).Offset(, 4)
　　　　　　v(i) = Split(r.Value, "(")(0)
　　　　　　v(i + 3) = Split(Split(r.Value, "(")(1), ")")(0)
　　　　ElseIf InStr(r.Value, "すべて") <> 0 Then
　　　　　　i = 6
　　　　　　For j = 1 To 7
　　　　　　　　i = i + 1
　　　　　　　　v(i) = Replace(r.Value, "すべて", "")
　　　　　　Next j
　　　　ElseIf InStr(r.Value, "/") <> 0 Then
　　　　　　i = 6
　　　　　　For j = 1 To UBound(Split(r.Value, " "))
　　　　　　　　If IsNumeric(Split(r.Value, " ")(j)) Then
　　　　　　　　　　i = i + 1
　　　　　　　　　　v(i) = Split(r.Value, " ")(j)
　　　　　　　　End If
　　　　　　Next j
　　　　End If
　　　　If i = 13 Then
　　　　　　ra.Resize(, 13).Value = v
　　　　　　Set ra = Nothing
　　　　　　i = 0
　　　　　　k = k + 1
　　　　End If
　　Next
　　Set rr = Nothing
End Sub

補足

何度もマクロを作成していただき、本当にどうもありがとうございました。
希望通りの動きとなり、大満足です。
質問を締め切る際、再度ポイント発行させていただきます。
この度は本当にどうもありがとうございました。

回答No.15

n-jun

ANo.13です。

未熟ながらに渋太く挑戦しました。
新たな補足があったようですので、変更しました。

Sub　TRY_next()
　Dim　RegExp　As　Object
　Dim　r　As　Range
　Dim　rr　As　Range
　Dim　rm　As　Range
　Dim　i　As　Integer,　j　As　Integer
　Dim　match,　v
　ReDim　v(1　To　1,　1　To　7)

　Set　RegExp　=　CreateObject("VBScript.Regexp")
　RegExp.Pattern　=　"\d+"
　RegExp.Global　=　True

　i　=　7
　For　Each　r　In　Range("D1",　Cells(Rows.Count,　4).End(xlUp))
　　　　　If　Not　IsEmpty(r.Offset(,　-3))　Then　Set　rm　=　r
　　　　　If　InStr(r.Value,　"(")　And　rr　Is　Nothing　Then
　　　　　　　　Set　rr　=　r.Resize(3)
　　　　　　　　If　Not　rm　Is　Nothing　Then
　　　　　　　　　　　For　j　=　1　To　3
　　　　　　　　　　　　　　　v(1,　j)　=　Split(Replace(rr.Item(j).Value,　")",　""),　"(")(0)
　　　　　　　　　　　　　　　v(1,　j　+　3)　=　Split(Replace(rr.Item(j).Value,　")",　""),　"(")(1)
　　　　　　　　　　　Next
　　　　　　　　　　　With　rr.Resize(1).Offset(3)
　　　　　　　　　　　　　　　　If　InStr(.Value,　"すべて")　Then
　　　　　　　　　　　　　　　　　　　ReDim　Preserve　v(1　To　1,　1　To　13)
　　　　　　　　　　　　　　　　　　　For　j　=　7　To　13
　　　　　　　　　　　　　　　　　　　　　　　v(1,　j)　=　Replace(.Value,　"すべて",　"")
　　　　　　　　　　　　　　　　　　　Next
　　　　　　　　　　　　　　　　ElseIf　RegExp.test(.Value)　Then
　　　　　　　　　　　　　　　　　　　For　Each　match　In　RegExp.Execute(.Value)
　　　　　　　　　　　　　　　　　　　　　　　v(1,　i)　=　match.Value
　　　　　　　　　　　　　　　　　　　　　　　i　=　i　+　1
　　　　　　　　　　　　　　　　　　　　　　　ReDim　Preserve　v(1　To　1,　1　To　i)
　　　　　　　　　　　　　　　　　　　Next
　　　　　　　　　　　　　　　　End　If
　　　　　　　　　　　End　With
　　　　　　　　　　　rm.Offset(,　1).Resize(,　UBound(v,　2)).Value　=　v
　　　　　　　　　　　Set　rm　=　Nothing
　　　　　　　　End　If
　　　　　ElseIf　LenB(r.Value)　<　1　Or　(r.Value　=　StrConv(r.Value,　vbWide))　Then
　　　　　　　　Set　rr　=　Nothing
　　　　　　　　i　=　7
　　　　　　　　ReDim　v(1　To　1,　1　To　7)
　　　　　End　If
　Next
　Set　RegExp　=　Nothing
　Set　rr　=　Nothing
　Set　rm　=　Nothing
　Erase　v
End　Sub

結構ごちゃごちゃしてますが。
（正規表現使わなければもう少し行が減るかな？⇒単なる好みと思って下さい。）

お礼

すみません、説明不足な気がしたので再度お礼欄で失礼します…
A列が空欄の行を全て削除=削除後は上にシフトする状態
D列を全て削除=削除後は左にシフトする状態(今までのE列がD列になる状態)
こういう意味です。

D列の削除くらいは手動でやっても大した作業ではありませんので
こちらはスルーしていただいてもかまいません。
お手数おかけしますが、よろしくお願いします。

補足

希望通りの動きとなり、大満足です。
前々回から、本当に本当にどうもありがとうございました。

あつかましいのですが、もう一つお願いしてもよろしいでしょうか…
新しくスレッドを作るべきかと思ったのですが
無関係という訳ではないのでこちらでお願いしたいと思います。

今回のマクロを実行したあと、必要なデータは全て
A列に数字のある行に入った状態となります。
A列が空欄の行(数字が入っていない行)と、
データを抜き取ったD列を全て削除したいのですが
そのマクロを作っていただけないでしょうか。

今回作っていただいたマクロを実行した後、
データがきちんと書き出されているかある程度目で確認したいので
今回のマクロに組み込んでいただくのではなく
別のマクロとして組んでいただければ助かります。
本当に何度もあつかましいのですが、よろしければお願いいたします。

回答No.14

xls88

これでどうでしょうか。

Sub test3()
　　Dim r As Range
　　Dim rr As Range
　　Dim ra As Range
　　Dim rd As Range
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Dim v(1 To 13) As Variant

　　Set rr = Range("A1", Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants, 1)
　　For Each r In Range("D1", Cells(Rows.Count, "D").End(xlUp))
　　　　If InStr(r.Value, "(") <> 0 And InStr(r.Value, ")") <> 0 Then
　　　　　　i = i + 1
　　　　　　If i = 1 Then Set ra = rr.Areas(k + 1).Offset(, 4)
　　　　　　v(i) = Split(r.Value, "(")(0)
　　　　　　v(i + 3) = Split(Split(r.Value, "(")(1), ")")(0)
　　　　ElseIf InStr(r.Value, "/") <> 0 Then
　　　　　　i = 6
　　　　　　For j = 1 To UBound(Split(r.Value, " "))
　　　　　　　　If IsNumeric(Split(r.Value, " ")(j)) Then
　　　　　　　　　　i = i + 1
　　　　　　　　　　v(i) = Split(r.Value, " ")(j)
　　　　　　　　End If
　　　　　　Next j
　　　　　　ra.Resize(, 13).Value = v
　　　　　　Set ra = Nothing
　　　　　　i = 0
　　　　　　k = k + 1
　　　　End If
　　Next
　　Set rr = Nothing
End Sub

＞ANo.13の補足
>xls88さんが書いてくれたANo.7のマクロでは、エラーはでないのですが
>C列のセルに半角英数(数字)という記載があった場合
>そのテーブルのみ展開されず、次のテーブルは展開されました
C列は見ていないので無関係です。
D列のデータに明らかにされていない形のものがあるのではないでしょうか。

補足

再作成ありがとうございます。
C列はまったく関係ありませんでした。お騒がせいたしました。
データ内容をよく見てみたところ、
D列の曜日のセルに別の形式がありました。
月 半角数字 / 火 半角数字 / ・・・・という形式以外に
月～日までの数字が同じ場合だと、　すべて半角数字　という形式のものが
数セル入っておりました…今更こんなのを発見してしまい、申し訳ありませんorz
これがあったため、K～Pまでが繰り上がって上に記載されたりして
書き出されていないように見えていたようです。

下記のような状態です
月 1 / 火 1 / 水 1 / 木 1 / 金 1 / 土 1 / 日 1
　↓　この場合下記のように記載されておりました
すべて1
「すべて」と数字の間にはスペースはありません。数字は必ず半角数字です。
こういう形式で書かれているセルが少ししかなかったので見逃しておりました…申し訳ありません。

具体的には下記のようなデータとなります
A1　数字
D6:D8　数字(数字)
D9　月 1 / 火 1 / 水 1 / 木 1 / 金 1 / 土 1 / 日 1

A11　数字
D14:D16　数字(数字)
D17　すべて1

A19　数字
D23:D25　数字(数字)
D26　月 1 / 火 1 / 水 1 / 木 1 / 金 1 / 土 1 / 日 1

A28　数字
D31:D33　数字(数字)
D34　すべて100

曜日の部分の記載が「すべて数字」という形式となっている箇所があった場合
数字の部分のみをK～Qにを書き出すように直していただく事は可能でしょうか…
またはKにだけ数字を書き出してもらえれば、自分でQまでコピーますので
それでもかまいません。お手数おかけいたしますが、よろしくお願いします。

なおn-junさんが書いてくださったANo.5のマクロだと、Kにだけ数字が入り、
繰り上がって書き出される事はありませんでした。

imogasiさんが書いてくださったANo.6のマクロではK以降に数字は入らず
繰り上がって書き出される事はありませんでした。

また後から追加の条件を出してしまい、本当に申し訳ありませんがよろしくお願いいたします( TДT)

回答No.13

n-jun

ANo.10の補足について。

こちらでテストした範囲ではデータ【数値(数値)】の()が全角の場合にエラーになりましたが。
ただxls88さんのコードで同様のエラーが出ていないのが少し不思議な感じがしました。

たぶん未熟故の事でしょうから、私はお手上げですね。

お礼

申し訳ございません、上の補足の内容は間違いです・・・お礼の欄に失礼します。
色々試しているうちに、D1に数字(数字)というのが入っていたせいでエラーがでておりました。
C列はまったく関係なかったようです、本当に申し訳ありません。。。

なお、D1を消して再度試してみたところ、エラーは出ませんでしたが
下記のデータで試したところ
A1　数字
D1:D5　空欄
D6:D10　４つの塊

A11　数字
D11:D13　空欄
D14:D17　４つの塊

結果はこうなりました
・D6:D10はE6：Q10に書き出されました（E1:Q1に書き出したい）
・D14:D17はE14:E17に書き出されました（E11：Q11に書き出したい）

補足

何度も申し訳ないです・・
データの状態で、書き漏れしているのはC列の内容になります。
C列にC列に半角英数(数字)という記載があったせいでした。
（必ず入っているという訳ではありませんが、今回試したデータのC2がそのセルでした）
C列のセルの内容は、各テーブルの一番上の行(Aに数字が入ってる行)以外は
一切必要ないので、最初に「(」でC列を検索して、該当するセルを消去したところ
ANo.7の補足に書いた結果とまったく同じく
D列の４つの塊の先頭行のE～Qに書き出される形となりました。

xls88さんが書いてくれたANo.7のマクロでは、エラーはでないのですが
C列のセルに半角英数(数字)という記載があった場合
そのテーブルのみ展開されず、次のテーブルは展開されました

回答No.12

xls88

＞ANo.7の補足

前回の質問へのリンク：​http://okwave.jp/qa4383630.html
>D1～D4と同じ書式のセルが何度もでてきます。
>その都度、横の欄に書き出せればと思っています。
>（D8～D11のように同じ書式が出てきた場合はE8～Q8に書き出す形）
というようにしてあります。
その際、D列のデータを判定しています。
ですから
>○D6:D10はE1:EQに書き出すことに成功しました
>×D14:D17はE14：Q14に書き出されました（E11:Q11に書き出したい）
>×D23:D26はE23:E26に書き出されました（E19：Q19に書き出したい）
この結果はおかしいです。
D列のセルデータが期待したようになっていない可能性があります。

どちらにしても
>D列から抽出した数値を、E～Qに書き出すように作成していただきました。
>この書き出し先を「A列に数字が入っている行のE～Q」に変更していただきたいです。
>(A1に数字が入っていたら、E1～Q1に書き出すようなかたち)
>A列には数行置きに数字が入っております。数字は全て半角英数です。
>数字以外は、全て空欄のセルです（A1に数字、A2～A5まで空欄、A6に数字というような感じです）
ということですから、新しい仕様に対応するようにコードを見直す必要があります。

回答No.11

n-jun

ANo.9です。

＞試した時にA1に数字があり、D1～D5まで空欄がある状態でした。
この条件でテストした所エラーは出てませんので、詳細はデータがなければわかりません。
（提示ではなく、ファイルのことです。）
何か提示されていないデータの存在があるものと推測するくらいです。
あとは実際のファイルでデバッグしていくしかないですが、それは私には無理です。

書き出す位置については、＃１０の通りです。

回答No.10

n-jun

ANo.8の２回目です。

ここを見落としてました。
＞呼び出されているテーブルの始まりがA1（テーブルの一番左上のセル）なので
＞その横の欄のE～Qに、D列の4つの塊のセルの内容を書き出せる形になれば
＞作業が大変楽になるのですが…
ここが理解できません。
結局Ｅ列以降に書き出す行は、何を基準に決まるのですか？

蛇足ですが。
＞なんとかなるようでしたら再度作成をお願いいたします。
回答されたコードのテストをされていなくて、再度の作成依頼だと回答する側も落ち込みますよ。
補足の際には注意された方が宜しいかと。

補足

何度もお手数おかけして申し訳ないです。
テスト結果をちょうど補足で書いていたところでした。遅くなってすみません。
再度#5のマクロを実行した際のデータ状態を再度詳しく記載します。

A1　数字
D1:D5　空欄
D6:D10　４つの塊

A11　数字
D11:D13　空欄
D14:D17　４つの塊

この状態で実行したところ下記のようにエラーがでました
実行時エラー'9':
インデックスが有効範囲にありません
と出てます。デバックを選ぶと
v(1, j) = Split(Replace(rr.Item(j).Value, ")", ""), "(")(0)
この部分が黄色になり、E～Qには全く書き出しできない状態です。

書き出し先ですが、
D6:D10を展開したものをE1:EQに
D14:D17を展開したものをE14：Q14に書き出したいです。
書き出し先の基準はA欄に数字がある場合のE～Qです。
上の例でいくと、A1～A11の間は空欄のセルしかありません。
間が必ず10行と決まっている訳ではありませんので
Aに数字が入っているセルの行のE～Qに…という意味です。

回答No.9

n-jun

ANo.8です。

言葉だけの説明よりもデータの状態を提示された方が、伝わるかと思います。

で、＃５は＃８の補足事項に対しては、一応考慮して作成しましたがそれでも無理だったでしょうか。

どのコードでどの部分がエラーになるとか、結果がこう違うとか、その辺りの補足も欲しいかと。

補足

レスありがとうございます。
#5のマクロを試したところエラーがでて書き出しできない状態です。
実行時エラー'9':
インデックスが有効範囲にありません
と出てます。デバックを選ぶと
v(1, j) = Split(Replace(rr.Item(j).Value, ")", ""), "(")(0)
この部分が黄色になります。

試した時にA1に数字があり、D1～D5まで空欄がある状態でした。
試しにD1～D5を削除し、上にシフトしたところエラーはでなくなったのですが、
その次のE～Qの書き出し先が、Aに数字が入っている行でもなく
D欄の塊の先頭の行でもなく、適当に？書き出されてしまいます。

回答No.8

n-jun

ANo.5です。

どうも初級レベルの私ですから、コードを複雑化してしまっているようで申し訳ないですし、
やっぱり解釈が違うような気がする。。。？

＞A列には数行置きに数字が入っております。数字は全て半角英数です。
＞数字以外は、全て空欄のセルです（A1に数字、A2～A5まで空欄、A6に数字というような感じです）
Ｅ列以降に書き出すのは、Ａ列に値がある場合のみと解釈していたのですが違うようであればスル～して下さい。

補足

皆様、レス本当にありがとうございます。
マクロの作成もありがとうございます。

説明不足で申し訳ありません。最新の回答であるこちらのレスに説明させていただきます。
書き出しはすべて同一シート内（アクティブなシート）でという意味です。
D列にある４つの塊の最初（たとえばD8)と、A列の数値の入っているセルは同じ列にはありません。
A1に数字があり、D8に塊の先頭行があるような感じで、かなりずれています。
間が7行と決まっている訳ではなく
A12に数字があり、D16に塊の先頭があったりと、間の行はランダムです。
前回の質問の際、D列の説明をD1からはじめていたので混乱させてしまいすみません。

元々HTMLのテーブルの部分をコピペしたもので
そのHTMLはincludeで沢山のテーブルを呼び出したHTMLです。
呼び出されたテーブルは基本的に同じ形式なのですが
（A1に数字B1、C1、D1に文字や数字等が入っており、D4あたりに4つの塊の先頭がある）
そのテーブルの縦の長さは定まっておらず、C列に入るセル数によって縦の長さが変化します。
AB列はテーブルの一番上の段にしか記載されないので、C列が長くなればそれにあわせて空欄セルが増えていきます。
C列は、D列の行タイトル？のような役割のセルもあり
C列にセルが増えると、D列には数字や文字が入ります。D列には、必ず4つの塊になる部分は出てきます。
C列には行タイトルの役割のないセルもあるので、その場合はD列に空欄が入ります。

呼び出されているテーブルの始まりがA1（テーブルの一番左上のセル）なので
その横の欄のE～Qに、D列の4つの塊のセルの内容を書き出せる形になれば
作業が大変楽になるのですが…
上手く説明できずに申し訳ございません<(_ _)>
ご面倒をおかけしますが、なんとかなるようでしたら再度作成をお願いいたします。

回答No.7

xls88

これぐらいでどうでしょうか。

Sub test()
　　Dim r As Range
　　Dim ra As Range
　　Dim i As Long
　　Dim j As Long

　　For Each r In Range("D1", Cells(Rows.Count, "D").End(xlUp))
　　　　If InStr(r.Value, "(") <> 0 And InStr(r.Value, ")") <> 0 Then
　　　　　　i = i + 1
　　　　　　If i = 1 Then Set ra = r
　　　　　　ra.Offset(, i).Value = Split(r.Value, "(")(0)
　　　　　　ra.Offset(, i + 3).Value = Split(Split(r.Value, "(")(1), ")")(0)
　　　　ElseIf InStr(r.Value, "/") <> 0 Then
　　　　　　i = 6
　　　　　　For j = 1 To UBound(Split(r.Value, " "))
　　　　　　　　If IsNumeric(Split(r.Value, " ")(j)) Then
　　　　　　　　　　i = i + 1
　　　　　　　　　　ra.Offset(, i).Value = Split(r.Value, " ")(j)
　　　　　　　　End If
　　　　　　Next j
　　　　　　Set ra = Nothing
　　　　　　i = 0
　　　　End If
　　Next
End Sub

補足

マクロ作成ありがとうございます。
データの内容の詳細について、ANo.8に補足してありますますので
もしよろしければご覧くださいませ。

今回試した際のデータの状態は次のとおりです
A1　数字
D6:D10　４つの塊

A11　数字
D14:D17　４つの塊

A19　数字
D23:D26　４つの塊

このデータの状態で試しました

○D6:D10はE1:EQに書き出すことに成功しました
×D14:D17はE14：Q14に書き出されました（E11:Q11に書き出したい）
×D23:D26はE23:E26に書き出されました（E19：Q19に書き出したい）

このようになりました。
もし可能でしたら（）内のように書き出せるように修正お願いいたします。