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

Question

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

n-jun · Accepted Answer

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
これかな？

xls88 · Answer

これでどうでしょうか。

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

n-jun · Answer

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

xls88 · Answer

これでどうでしょうか。

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列のデータに明らかにされていない形のものがあるのではないでしょうか。

n-jun · Answer

ANo.10の補足について。

こちらでテストした範囲ではデータ【数値(数値)】の()が全角の場合にエラーになりましたが。
ただxls88さんのコードで同様のエラーが出ていないのが少し不思議な感じがしました。

たぶん未熟故の事でしょうから、私はお手上げですね。

xls88 · Answer

＞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に数字というような感じです）
ということですから、新しい仕様に対応するようにコードを見直す必要があります。

n-jun · Answer

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

n-jun · Answer

ANo.8の２回目です。

ここを見落としてました。
＞呼び出されているテーブルの始まりがA1（テーブルの一番左上のセル）なので
＞その横の欄のE～Qに、D列の4つの塊のセルの内容を書き出せる形になれば
＞作業が大変楽になるのですが…
ここが理解できません。
結局Ｅ列以降に書き出す行は、何を基準に決まるのですか？

蛇足ですが。
＞なんとかなるようでしたら再度作成をお願いいたします。
回答されたコードのテストをされていなくて、再度の作成依頼だと回答する側も落ち込みますよ。
補足の際には注意された方が宜しいかと。

n-jun · Answer

ANo.8です。

言葉だけの説明よりもデータの状態を提示された方が、伝わるかと思います。

で、＃５は＃８の補足事項に対しては、一応考慮して作成しましたがそれでも無理だったでしょうか。

どのコードでどの部分がエラーになるとか、結果がこう違うとか、その辺りの補足も欲しいかと。

n-jun · Answer

ANo.5です。

どうも初級レベルの私ですから、コードを複雑化してしまっているようで申し訳ないですし、
やっぱり解釈が違うような気がする。。。？

＞A列には数行置きに数字が入っております。数字は全て半角英数です。
＞数字以外は、全て空欄のセルです（A1に数字、A2～A5まで空欄、A6に数字というような感じです）
Ｅ列以降に書き出すのは、Ａ列に値がある場合のみと解釈していたのですが違うようであればスル～して下さい。

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

ANo.15です。

これでどうでしょうか。

この回答への補足

ANo.13です。

この回答への補足

これでどうでしょうか。

この回答への補足

ANo.10の補足について。

この回答への補足

＞ANo.7の補足

ANo.9です。

ANo.8の２回目です。

この回答への補足

ANo.8です。

この回答への補足

ANo.5です。

この回答への補足

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

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

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

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