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

質問

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

前回の質問へのリンク：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.6

imogasi

#3です。＃３はロジックがごたごたしていたのが気になって、再度考えて、少しすっきりさせました。
＃３と同じ例でデ－タでテスト
ーー
コード
Sub test02()
d = Range("D65536").End(xlUp).Row '最下行数取得
Ln = 5 '初期状態の意味で４以上をセット
For i = 1 To d '最下行以内で繰り返し
p = InStr(Cells(i, "D"), "(") '（を探す
If p <> 0 Then '（があったとき
If Ln > 4 Then
Ln = 0 '塊内の４行目以下なら最初の（ありはｌｎ＝０にして
k = i '塊の中の第１行を記録する
End If
End If
Ln = Ln + 1 '塊内の行番号を１加える
Select Case Ln
Case 1, 2, 3 '塊内の第１，２，３行目では
x = Split(Cells(i, "D"), "(") '(でセルの値分離
j = Ln + 4 'E,H,I
Cells(k, j) = Mid(Cells(i, "D"), 1, p - 1) 'E列などへセット
Cells(k, j + 3) = Mid(Cells(i, "D"), p + 1, Len(Cells(i, "D")) - p - 1)
Case 4 '塊内の第４行目は
z = Split(Cells(i, "D"), "/") '/で分離
For j = 11 To 11 + UBound(z) - 1 'K-Q列にセットの繰り返し
Cells(k, j) = Mid(z(j - 11), 3, Len(z(j - 11)) - 2)
Next j
Case Else '塊内の第５行目以下は
'何もしない
End Select
Next i
End Sub

お礼

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

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

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

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

補足

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

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

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

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

マクロを実行したところ、次のようにエラーが出ました。
実行時エラー'5':
プロシージャの呼び出し、または引数が不正です。

デバックをすると
Cells(k, j) = Mid(Cells(i, "D"), 1, p - 1) 'E列などへセット
上の部分が黄色になります。

実際に書き出されたのは下記の通りです
D1のセルにある　数字1(数字2)
E1に数字1、H1に数字2
それ以外は書き出す事ができませんでした。

回答No.5

n-jun

ANo.4です。
自信はありませんが、たぶんこうではないかと解釈してトライしました。

Sub　TRY()
　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　7)

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

　Set　rs　=　Range("A1"):　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)
　　　　　　　　Set　rs　=　Union(rs,　rr.Offset(,　-3))
　　　　　　　　If　WorksheetFunction.Count(rs)　>　0　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　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
　　　　　　　　　　　rr.Item(1).Offset(,　1).Resize(,　UBound(v,　2)).Value　=　v
　　　　　　　　　　　Set　rs　=　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
　　　　　If　rs　Is　Nothing　Then
　　　　　　　　Set　rs　=　r.Offset(,　-3)
　　　　　Else
　　　　　　　　Set　rs　=　Union(rs,　r.Offset(,　-3))
　　　　　End　If
　Next
　Set　RegExp　=　Nothing
　Set　rr　=　Nothing
　Set　rs　=　Nothing
　Erase　v
End　Sub
不具合があればご指摘願います。

回答No.4

n-jun

ANo.1です。

何となく条件を取り違えていたようですので、＃１はスル～して下さい。

データの塊の区切りに必ず空白行があるかどうかで分かれそうです。

回答No.3

imogasi

基本的なことがわからない。前質問の
D1　20(150)
D2　300(100)
D3　40(60)
・・
はシート１にあるとすると、横（行方向）に組み替えた結果を出しのは
シート１においてか？シート２（別シート）か？
どうも同一シートのE列より右列にらしいですね。
ーー
今回の質問の質問の
＞A列に数字が入っている行
とは
これも元データと同一シートの上のE列より右列にか？
それと＞列に数字が入っている行とは
D1　20(150)
D2　300(100)
D3　40(60)
・・・
D8　10(50)
D9　200(200)
D10　30(90)
・・
のD1とか、D8の行のことを言うのか？
むしろ塊ごとの最初の数字行の横にというべきことか？
前質問の「完璧な」回答はE-Q列は、どういう行にだして
居たのか。
ーーー
ルール性が前質問にも十分説明されていないと思う。
D1、D8,・・を捕まえるのはどういう風に考えればよいのか。
各塊（行のまとまり）においてで、D列セルで（が最初に含むセルを
各塊の最初と見てよいのか。
＞上の例では3個ですが、4個だったり5個だったりランダムです）
とあるので各塊の行数は一定しない（７ではない）ということですね。
下記では、曜日の入った行は１行、それまでのD1-D3のようなデータは３行に決まっているとする。
良くわからないが下記やってみた。前回答と違うので、質問者は混乱するかも知れない。ソウであれば、下記を無視しても結構。
しかし下記で私はロジックには苦労した。
ーー
例データ
D1:D22
20(150)
300(100)
40(60)
月 10 / 火 15 / 水 200 / 木 50 / 金 52 / 土 20 / 日 100 /
空欄
全角文字
半角数字
10(50)
200(200)
30(90)
月 30 / 火 18 / 水 100 / 木 150 / 金 352 / 土 120 / 日 150 /
全角文字
空欄
全角文字
半角数字
全角文字
10(50)
200(200)
30(90)
月 40 / 火 20 / 水 120 / 木 160 / 金 35 / 土 137 / 日 155 /
全角文字
半角数字
ーー
コード
Sub test01()
d = Range("D65536").End(xlUp).Row '最下行数取得
i = 1
While i < d + 1 '最下行以内で繰り返し
p = InStr(Cells(i, "D"), "(") '（を探す
If p <> 0 Then '（があったとき
j = 5 'E列以右で始点列E列指定
For k = i To i + 2 '(ありは続き３列と仮定
p = InStr(Cells(k, "D"), "(") '（あるか
If p <> 0 Then '（あり
x = Split(Cells(k, "D"), "(") '(でセルの値分離
Cells(i, j) = Mid(Cells(k, "D"), 1, p - 1) 'E列などへセット
Cells(i, j + 3) = Mid(Cells(k, "D"), p + 1, Len(Cells(k, "D")) - p - 1)
j = j + 1 '次のサイクル
End If
Next k '（ありの３行の塊の内の次の行を対象
y = Cells(i + 3, "D") '（ありの３行の塊の後の次の行を対象
z = Split(y, "/") '/で分離
For j = 11 To 11 + UBound(z) - 1 'K-Q列にセットの繰り返し
Cells(i, j) = Mid(z(j - 11), 3, Len(z(j - 11)) - 2)
Next j
i = i + 3 '（ありの３行済ましたので
End If
i = i + 1 '（がなかったときはここへ合流、次の行の処理に移る
Wend
End Sub
ーーー
結果
第1行E列以右
20 300 40 150 100 60 10 15 200 50 52 20 100
第８行E列以右
10 200 30 50 200 90 30 18 100 150 352 120 150
第１７行E列以右
10 200 30 50 200 90 40 20 120 160 35 137 155

回答No.2

xls88

失礼します。
下記のようにしてみました。

Sub test2()
　　Dim RegExp As Object
　　Dim r As Range
　　Dim rr As Range, rs As Range
　　Dim i As Integer, j As Integer
　　Dim k 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 rs Is Nothing Then
　　　　　　k = k + 1
　　　　　　If k = 1 Then Set rs = r
　　　　　　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 Not rs Is Nothing Then
　　　　　　If r.row = rs.Offset(4).row Then
　　　　　　　　Set rs = Nothing
　　　　　　　　k = 0
　　　　　　　　i = 7
　　　　　　End If
　　　　End If
　　Next
　　Set RegExp = Nothing
　　Set rr = Nothing
　　Erase v
End Sub

回答No.1

n-jun

ようは「Ａ列が""でなければいい」と言う事でもいいんですよね？

If　InStr(r.Value,　"(")　And　rr　Is　Nothing　Then
を
If InStr(r.Value, "(") And rr Is Nothing And r.Offset(, -3).Value <> "" Then
では。