EｘcelのVBAによるプログラム

質問

恐れ入りますが、以下の条件分岐に関するプログラムについてご教授ください。よろしくお願い致します。

No　　データ１　　データ２
１　　０．５　　　０．２
２　　０．０１　　１．２
３　　０．００８　１．０
４　　０．０３　　０．３
５　　０．０２　　０．４

上記の様な集録データで、「データ１」が０．０１以下のときの「集録ナンバーおよびデータ２」を抽出したいと思っています。
例えば、上記の例から考えますと、「No２と１．２」と「No３と１．０」ということになります。
しかし、このように連続したナンバーの場合だけは、最初の「No２と１．２」だけを抽出したいのです。こうしたプログラムについて、アドバイスをお願いいたします。

回答No.7

Wendy02 · ベストアンサー

こんばんは。

>データのないものを１つ、最後に抽出するようになっています。
データのないNoは、Ar3の変数に、すべて確保されていますが、そのうち1つだけ出すようにされています。

それと、結合されたセルを使う場合は、バージョンにもよりすが、Excelのバグが存在していますので、マクロでは問題ないとは思いますが、コピー＆ペーストで、右側領域のセルでエラーを誘発することがありますから、十分に注意してください。出来る限り、広い領域で結合セルは使わないほうが良いようです。

'-------------------------------------------

Sub PicupNo3()
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Dim ar As Variant
　　Dim ar2() As Variant
　　Dim ar3() As Variant
　　With ActiveSheet
　　　　ar = .Range(.Cells(20, 4), .Cells(Rows.Count, 4).End(xlUp)).Resize(, 12)
　　　　For i = LBound(ar, 1) To UBound(ar, 1)
　　　　　　 If IsEmpty(ar(i, 5)) Or Trim(ar(i, 5)) = "" Then
　　　　　　　 ReDim Preserve ar3(k)
　　　　　　　 ar3(k) = ar(i, 1)
　　　　　　　 k = k + 1
　　　　　　End If
　　　　　　If ar(i, 5) <= 0.01 Then
　　　　　　　　ReDim Preserve ar2(2, j)
　　　　　　　　If j > 0 Then
　　　　　　　　　　If ar(i, 1) > (ar2(0, j - 1) + 1) Then
　　　　　　　　　　　　ar2(0, j) = ar(i, 1)
　　　　　　　　　　　　ar2(1, j) = ar(i, 5)
　　　　　　　　　　　　ar2(2, j) = ar(i, 9)
　　　　　　　　　　　　j = j + 1
　　　　　　　　　　End If
　　　　　　　　Else
　　　　　　　　　　ar2(0, j) = ar(i, 1)
　　　　　　　　　　ar2(1, j) = ar(i, 5)
　　　　　　　　　　ar2(2, j) = ar(i, 9)
　　　　　　　　　　j = j + 1
　　　　　　　　End If
　　　　　　End If
　　　　Next i
　　　　For i = LBound(ar2, 2) To UBound(ar2, 2)
　　　　 With .Cells(20 + i, 19)
　　　　　 .Offset(0, 0).MergeArea.Value = ar2(0, i)
　　　　　 .Offset(0, 4).MergeArea.Value = ar2(1, i)
　　　　　 .Offset(0, 8).MergeArea.Value = ar2(2, i)
　　　　　End With
　　　　Next i
　　　　'データのないNo
　　　　.Cells(20 + i, 19).Value = "データのないNo"
　　　　.Cells(20 + i + 1, 19).Value = ar3(0)
　　End With
End Sub

お礼

勉強になります。
ご親切にありがとうございました。

回答No.8

van111

no5です。

>>ナンバーのみすべてのセルにふっていたものですから、データのないものを１つ、最後に抽出するようになっています。

少し理解に欠けますが、要するにdata1が空白ならばわかりやすいように
記述をするということの認識でよろしいでしょうか？
一度下記記述で確認お願いいたします。

Sub test()
i = 2: h = 1
Do While Cells(i, 1) <> ""
If Cells(i, 2) = "" Then
Cells(i, 5).Value = "DATAがありません"
Else
If Cells(i, 2) <= 0.01 Then
If Cells(i - 1, 2) > 0.01 Then
Cells(h, 5).Value = "no" & Cells(i, 1).Value & " " & Cells(i, 3).Value
h = h + 1
End If
End If
End If
i = i + 1
Loop
End Sub

お礼

大変勉強になりました。
お力添え，ありがとうございました。

回答No.6

imogasi

こんなの処理ロジッが大切で、それだけなら、ＶＢＡを知らなくてもできる。
そのロジックがわからないのだろう。だから質問者は丸投げにならざるを得ない。
ロジックは色々な方法が考えられ、コード行数や誤処理に影響を及ぼす。
一例で
処理は上行から下へ１行ずつ処理する（Ｆｏｒ　Ｎｅｘｔ）
「条件に合うもの（行）」の直近の行番号（Ａ）を覚える変数を持っておく。
条件の判定をして、該当なら、今のセルの行番号がＡ＋１なら書き出さない。そしてＡ＝Ａ＋１とする。
Ａ＝Ａ＋１でなければ、書き出す。そしてＡ＝０にでもしておく。
条件が合わない行なら、Ａ＝０にして、何もしないで次の行に行く。
ーー
結局場合分けの切り分けを見抜くことだ。
これはプログラムを多数経験して会得しないとならない。
＝＝
＞抽出したデータを上詰めで整理していくための方法
書き出すシートの行番号を保持する変数Ｋを作って、書き出しの都度
Ｋ＝Ｋ＋１しておくと良い。
ーー
次々要求が出ているようだが、丸投げで、回答をコピペせざるを得ないだけのレベルらしいが、経験をつんでロジックを組み立てて、それを決めて、それを実現する数行のコード群が作れることが必要。
コードはあえて書かない。
ーー
無理しないで、関数で作業列を使い、条件充足のサインを立て、フィルタを使ってでも抜き出して、処理したら。

お礼

コードに関する学習が不十分で，みなさんにご迷惑おかけしております。厳しいご指摘，肝に銘じておきます。
個人で活用するものであるならば「関数で作業列を使い、条件充足のサインを立て、フィルタを使ってでも抜き出して、処理」という方法で十分だったのですが，子どもから大人まで共有できるものが必要となり，不慣れにも自動化を試みようとした次第です。
ありがとうございました。

回答No.5

van111

no2です。

上詰めでいいんですね？
ならこんな感じでしょうか？
違ってたらすいません。
Sub test()

i = 2: h = 1
Do While Cells(i, 1) <> ""
If Cells(i, 2) <= 0.01 Then
If Cells(i - 1, 2) > 0.01 Then
Cells(h, 5).Value = "no" & Cells(i, 1).Value & " " & Cells(i, 3).Value
h = h + 1
End If
End If
i = i + 1
Loop
End Sub

お礼

ご回答、ありがとうございました。
van111さん、そしてWendy02さんに心より感謝申し上げます。

このプログラム、早速仕様に合わせて改良させていただき、活用致しましたところ、ナンバーのみすべてのセルにふっていたものですから、データのないものを１つ、最後に抽出するようになっています。打開策がありましたら、またの機会によろしくお願いいたします。

回答No.4

Wendy02

こんにちは。

#3は、正規化ではなかったのではないのですね。#1の補足を読み違えました。

>No3のデータ２「1.０」が残ってしまうといった状況です。
は、残すようにしてありました。

>つまり，０．０１以下のデータはすべてほしいのですが，ナンバーが連続した場合のみ，最初のナンバーだけ…という訳です。

最初という意味が、分かりませんでした。言葉では難しいです。

Sub PicupNo2()
　　Dim i As Long
　　Dim j As Long
　　Dim ar As Variant
　　Dim ar2() As Variant
　　With ActiveSheet
　　　　ar = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Resize(, 3)
　　　　For i = LBound(ar, 1) To UBound(ar, 1)
　　　　　　If ar(i, 2) <= 0.01 Then
　　　　　　　　ReDim Preserve ar2(1, j)
　　　　　　　　 '正規化ではなかった
　　　　　　　　If j > 0 Then
　　　　　　　　　　If ar(i, 1) > (ar2(0, j - 1) + 1) Then
　　　　　　　　　　　　ar2(0, j) = ar(i, 1)
　　　　　　　　　　　　ar2(1, j) = ar(i, 3)
　　　　　　　　　　　　j = j + 1
　　　　　　　　　　End If
　　　　　　　　Else
　　　　　　　　　　ar2(0, j) = ar(i, 1)
　　　　　　　　　　ar2(1, j) = ar(i, 3)
　　　　　　　　　　j = j + 1
　　　　　　　　End If
　　　　　　End If
　　　　Next i
　　　　.Cells(1, 5).Resize(, 2).Value = Array(.Cells(1, 1).Value, .Cells(1, 3).Value)
　　　　.Cells(2, 5).Resize(UBound(ar2, 2) + 1, UBound(ar2, 1) + 1) = _
　　　　Application.Transpose(ar2)
　　End With
End Sub

お礼

何度もご回答、ありがとうございました。Wendy02さんにご紹介いただいたプログラム、私には初めて目にするものがたくさんありまして、理解に窮しております。
具体的なお話で恐縮ですが、実のところ、以下のように結合された枠に集録されたデータを、

　　　D～G　　　H～K　　　　　L～O
20　　１　　　　０．５　　　　０．２
21　　２　　　　０．０１　　　１．２
22　　３　　　　０．００８　　１．０
23　　４　　　　０．０３　　　０．３
24　　５　　　　０．０１　　　０．４
・
・（5000くらいまで続いています）

こちらの枠へ抽出したいのです。

　　　S～V　　　　W～Z　　　　AA～AD
20　　２　　　　０．０１　　　１．２
21　　５　　　　０．０１　　　０．４
22

条件分岐についてはH～Kのセルが0.01以下であります。
重ね重ね申し訳ありませんが、もう一度お知恵を拝借できればと思っております。
お忙しいところすみませんm(__)m

回答No.3

Wendy02

こんにちは。

たぶん、数式のほうが楽かもしれませんね。
ご質問にブレがあるようですが、オートフィルタなどを使ったほうが楽なような気がします。

'-------------------------------------------
Sub PicupNo1()
　　Dim i As Long
　　Dim j As Long
　　Dim ar As Variant
　　Dim ar2() As Variant
　　With ActiveSheet
　　　　ar = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Resize(, 3)
　　　　For i = LBound(ar, 1) To UBound(ar, 1)
　　　　　　If ar(i, 2) <= 0.01 Then
　　　　　　　　ReDim Preserve ar2(1, j)
　　　　　　　　'正規化
　　　　　　　　If j > 0 Then
　　　　　　　　　　If ar(i, 1) > (ar2(0, j - 1) + 1) Then
　　　　　　　　　　　　ar2(0, j) = ar(i, 1)
　　　　　　　　　　End If
　　　　　　　　Else
　　　　　　　　　　ar2(0, j) = ar(i, 1)
　　　　　　　　End If
　　　　　　　　ar2(1, j) = ar(i, 3)
　　　　　　　　j = j + 1
　　　　　　End If
　　　　Next i
　　　　.Cells(1, 5).Resize(, 2).Value = .Cells(1, 2).Resize(, 2).Value
　　　　.Cells(2, 5).Resize(UBound(ar2, 2) + 1, UBound(ar2, 1) + 1) = _
　　　　Application.Transpose(ar2)
　　End With
End Sub
'-------------------------------------------

お礼

ご回答、ありがとうございました。
早速、活用させていただきましたところ、ほぼイメージどおりなのですが、No3のデータ２「1.０」が残ってしまうといった状況です。連続した場合は、最初のデータのみの抽出を考えておりまして、その点改良しようとしております。

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

回答No.2

van111

こんな感じかな？
Sub test()

i = 2
Do While Cells(i, 1) <> ""
If Cells(i, 2) <= 0.01 Then
If Cells(i - 1, 2) > 0.01 Then
Cells(i, 5).Value = "no" & Cells(i, 1).Value & " " & Cells(i, 3).Value
End If
End If
i = i + 1
Loop
End Sub

お礼

ご回答、ありがとうございました。
イメージに大変近いものができまして、ここからならば自分で何とかできそうです。
もしよろしければ、抽出したデータを上詰めで整理していくための方法も、合わせてご伝授いただければと思います。van111さんにご紹介いただいた方法ですと、データに並んだ形で整理されていくものですから。

ご親切にありがとうございました。

回答No.1

akina_line

こんにちは。

　>このように連続したナンバーの場合だけは、最初の「No２と１．２」だけを抽出したいのです
　連続していないナンバーの場合は、どうするのですか？
　例えば、６番目のデータとして、「６　０．００１　０．５」等というデータがあった場合は。。。
　あるいは、０．０１以下のデータがとびとびに３件あった場合とか。。
　プログラムを作成する場合、すべての条件が列記されていないと、思った通りの動作はしてくれませんよ。

補足願います。

補足

ご回答，ありがとうございました。ご説明が不十分でした。補足致します。
連続していないナンバーの場合は，すべて列挙させたいと考えています。例えば，akina_lineさんに挙げていただいた『６番目のデータとして、「６　０．００１　０．５」等というデータがあった場合』であれば，以下のような抽出データがほしいと思っています。

No　　データ１　　データ２
２　　０．０１　　１．２
６　　０．００１　０．５

つまり，０．０１以下のデータはすべてほしいのですが，ナンバーが連続した場合のみ，最初のナンバーだけ…という訳です。
お知恵がありましたら，よろしくお願い致します。