Excelで抽出、書き出しを繰り返すマクロ

質問

ExcelのD列に下記のように記載されたExcelの表があります
D1　20(150)
D2　300(100)
D3　40(60)
D4　月 10 / 火 15 / 水 200 / 木 50 / 金 52 / 土 20 / 日 100 /
D5　空欄
D6　全角文字
D7　半角数字
D8　10(50)
D9　200(200)
D10　30(90)
D11　月 30 / 火 18 / 水 100 / 木 150 / 金 352 / 土 120 / 日 150 /
D12　全角文字
・
・
・

これを、下記のように横一列に書き出したいです
E1=20,F1=300,G1=40　（D1～D3の()の左側の数値)
H1=150,I1=100,J1=60　（D1～D3の()の中の数値)
K1=10,L1=15,M1=200,N1=50,O1=52,P1=20,Q1=100　（D4の曜日と/の間の数値）

D1～D3(D8～D10)は全て半角です
D4(D11)は曜日以外のスペースや数字、/は全て半角です
D5～D7のようなセルが何個か間に入りますが（上の例では3個ですが、4個だったり5個だったりランダムです）
D1～D4と同じ書式のセルが何度もでてきます。
その都度、横の欄に書き出せればと思っています。
（D8～D11のように同じ書式が出てきた場合はE8～Q8に書き出す形）
上手く説明できなくて申し訳ないのですが
この作業を繰り返してくれるマクロを作成していただく事は可能でしょうか？
色々と指定が多いので、不可能でしょうか…
もし可能なようでしたら、大変ご面倒おかけしますが
作成していただけますと助かります。よろしくお願いします。

回答No.3

n-jun · ベストアンサー

ANo.1です。

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
ご参考程度に。

お礼

完璧に希望通りの動きでした！
面倒な事を何度もやっていただけて本当に感謝しております。
VBA入門サイトを見ても序盤のところから分からなくて
途方に暮れておりましたが、がんばって勉強してみたいと思います。
前回の質問に引き続き、本当にどうもありがとうございました。

回答No.4

n-jun

ANo.3です。

データの区切りとして空白セルが存在しない場合があり、且つ必ず”全角文字”で区切る事が出来るのであれば、

ElseIf　LenB(r.Value)　<　1　Then
を
ElseIf LenB(r.Value) < 1 Or (r.Value = StrConv(r.Value, vbWide)) Then
としてみて下さい。

それ以外で不具合があれば提示願います。

回答No.2

fujillin

2段階に分ければよいのでは？

１）列→行への変換は「形式を選択して貼り付け」で可能ですから
　　これをマクロの自動記録で行えば、ほぼ同等のコードができます
２）ANo1さんがご指摘のように（）内を取り出す部分は、すでにわかってい
るでしょうからこれを下の行に表示するようにする。

つなげたければ、そのままマクロをつなげればOKです。

回答No.1

n-jun

直接の回答ではないですが。

Excelのマクロで（）内の文字を抽出して書き出したい
http://okwave.jp/qa4373238.html

前回ご質問のリンクを貼っておいた方がBetterな気がしますけど。
（類似したご質問と受け取りました）

お礼

補足ありがとうございました。