こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

ExcelのVBAによるプログラム

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

No  データ1  データ2
1  0.5   0.2
2  0.01  1.2
3  0.008 1.0
4  0.03  0.3
5  0.02  0.4

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

投稿日時 - 2009-10-29 15:24:47

QNo.5406110

すぐに回答ほしいです

質問者が選んだベストアンサー

こんばんは。

>データのないものを1つ、最後に抽出するようになっています。
データのない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

投稿日時 - 2009-10-30 23:29:28

お礼

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

投稿日時 - 2009-11-04 00:38:59

ANo.7

このQ&Aは役に立ちましたか?

2人が「このQ&Aが役に立った」と投票しています

回答(8)

ANo.8

no5です。

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

少し理解に欠けますが、要するに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

投稿日時 - 2009-11-02 15:20:39

お礼

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

投稿日時 - 2009-11-04 00:41:26

ANo.6

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

投稿日時 - 2009-10-30 21:31:29

お礼

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

投稿日時 - 2009-11-04 02:04:14

ANo.5

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

投稿日時 - 2009-10-30 17:21:16

お礼

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

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

投稿日時 - 2009-10-30 18:15:55

ANo.4

こんにちは。

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

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

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

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

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

投稿日時 - 2009-10-30 15:35:00

お礼

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

   D~G   H~K     L~O
20  1    0.5    0.2
21  2    0.01   1.2
22  3    0.008  1.0
23  4    0.03   0.3
24  5    0.01   0.4

・(5000くらいまで続いています)

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

   S~V    W~Z    AA~AD
20  2    0.01   1.2
21  5    0.01   0.4
22

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

投稿日時 - 2009-10-30 16:42:50

ANo.3

こんにちは。

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


'-------------------------------------------
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
'-------------------------------------------

投稿日時 - 2009-10-30 13:27:05

お礼

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

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

投稿日時 - 2009-10-30 15:05:02

ANo.2

こんな感じかな?
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

投稿日時 - 2009-10-29 16:20:10

お礼

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

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

投稿日時 - 2009-10-30 14:36:37

ANo.1

こんにちは。

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

補足願います。

投稿日時 - 2009-10-29 16:15:27

補足

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

No  データ1  データ2
2  0.01  1.2
6  0.001 0.5

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

投稿日時 - 2009-10-29 17:31:45

あなたにオススメの質問