[[20150514132846]]　『VBAでの複数条件一致で値を抽出』（Q）　ページの最後に飛ぶ

『VBAでの複数条件一致で値を抽出』（Q）

A列、A9からみかん、りんご、なしなどの項目が入っております。
(A9～A28までセルが結合されていて縦書きで項目）

同じシート内にコンボボックスで項目名を選ぶものと
手書きで内容と開始日、終了日を記載してボタンを押すと
コンボボックスで指定した項目名の空白行をみつけて
上記内容を飛ぶようにしたいです。

上記の内容はAS1に項目名、AS2に内容、AS3に開始日、AS4に終了日
を一度飛ばし、そのあとボタン実行で各場所に飛ばしたいと思っています。

A列の項目名の中からAS1と同じものをみつけ
B列に内容、C列に開始日、D列に終了日をそれぞれ反映させるにはどのような
コードにすればよいでしょうか？

＜使用 Excel：Excel2010、使用 OS：Windows8 ＞

 A9:A28が結合、A29:A48が結合、・・ということでよろしいですね。
 どうも「とばし・・」という意味がわからないところもありますので、以下は誤解の産物かも。
 誤解していなかったとしても、今のところ不具合があります。一度コンボボックスで選び、
 シート上で何らかの作業を行った後、コンボボックスを選ぶとリストが１行だけ表示、横にスクロールボタンがついていて
 それを押して上下させる必要がでてきます。（このような経験は初めてです。原因は別途さぐりますが）

 とりあえず試行品として。

 15:00 追記　一応、不具合を回避しました。以下のコードを差し替えてあります。
　　　　　　不具合は回避しましたが、なぜ不具合が発生したのかはわかりません。
　　　　　　（オリジナルはコンボボックスにフォーカスがあたるたびにリストを瀬戸セット。それを、最初の１回目だけにしました）

 シートに ActiveX の ComboBox1 と　CommandButton1 を配置。
 シートモジュールに以下。

 Option Explicit

 Dim skip As Boolean
 Dim done As Boolean

 Private Sub ComboBox1_GotFocus()
    Dim c As Range
    If done Then Exit Sub
    done = True
    skip = True
    ComboBox1.Clear
    For Each c In Range("A9", Range("A" & Rows.Count).End(xlUp))
        If Not IsEmpty(c) Then ComboBox1.AddItem c.Value
    Next
    ComboBox1.Value = ""
    skip = False
 End Sub

 Private Sub ComboBox1_Change()
    If skip Then Exit Sub
    Range("AS1").Value = ComboBox1.Value
    Application.Goto Range("AS1")
 End Sub

 Private Sub CommandButton1_Click()
    Dim z As Variant
    Dim c As Range
    Dim r As Range
    If ComboBox1.Value = "" Then
        MsgBox "項目が選択されていません"
        Exit Sub
    End If
    z = Application.Match(ComboBox1.Value, Range("A9", Range("A" & Rows.Count).End(xlUp)), 0)
    If IsError(z) Then
        MsgBox "項目が見つかりません"
        Exit Sub
    End If
    z = z + 8
    Set r = Range("A" & z).MergeArea
    Set r = r.Offset(, 1).Resize(r.Rows.Count)
    Set c = r.Find(What:=vbNullString, LookAt:=xlPart, LookIn:=xlFormulas, After:=r.Cells(r.Count))
    If c Is Nothing Then
        MsgBox "満杯です"
        Exit Sub
    End If
    c.Value = Range("AS2").Value
    c.Offset(, 1).Value = Range("AS3").Value
    c.Offset(, 2).Value = Range("AS4").Value

 End Sub

（β） 2015/05/14(木) 14:35

 ↑　う～～ん・・・

 別の不具合発生です。

 もともとのコード：毎回リストをセット。　現象としては最初はＯＫだけど２回目からはスクロールボタンを押す必要がでてきた。

 改訂版　：最初の１回目のみセット。新たな現象として最初のみスクロールボタン。２回目からはＯＫ。

 原因は追究したいと思いますがとりあえず、がまんして使ってください。

（β） 2015/05/14(木) 15:07

 どうしても CotFocusを使うと、不具合が解消できません。
 モジュールがわかれてしまいますが、素直にリストの設定はブックが開かれたときに行う方法にします。
 シート名は実際のものにしてください。

 ThisWorkbook モジュール

 Option Explicit

 Private Sub Workbook_Open()
    Dim c As Range
    With Sheets("Sheet1")
        .OLEObjects("ComboBox1").Object.Clear
        For Each c In .Range("A9", .Range("A" & .Rows.Count).End(xlUp))
            If Not IsEmpty(c) Then .OLEObjects("ComboBox1").Object.AddItem c.Value
        Next
        .OLEObjects("ComboBox1").Object.Value = ""
    End With
 End Sub

 シートモジュール

 Option Explicit

 Private Sub ComboBox1_Change()
    If ComboBox1.Value = "" Then Exit Sub
    Range("AS1").Value = ComboBox1.Value
    Application.Goto Range("AS1")
 End Sub

 Private Sub CommandButton1_Click()
    Dim z As Variant
    Dim c As Range
    Dim r As Range
    If ComboBox1.Value = "" Then
        MsgBox "項目が選択されていません"
        Exit Sub
    End If
    z = Application.Match(ComboBox1.Value, Range("A9", Range("A" & Rows.Count).End(xlUp)), 0)
    If IsError(z) Then
        MsgBox "項目が見つかりません"
        Exit Sub
    End If
    z = z + 8
    Set r = Range("A" & z).MergeArea
    Set r = r.Offset(, 1).Resize(r.Rows.Count)
    Set c = r.Find(What:=vbNullString, LookAt:=xlPart, LookIn:=xlFormulas, After:=r.Cells(r.Count))
    If c Is Nothing Then
        MsgBox "満杯です"
        Exit Sub
    End If
    c.Value = Range("AS2").Value
    c.Offset(, 1).Value = Range("AS3").Value
    c.Offset(, 2).Value = Range("AS4").Value

 End Sub

（β） 2015/05/15(金) 06:22

返信おくれました。
コードありがとうございます！試してみたのですが、コンパイルエラー？というものが
一番最後のコードで出てしまいました…
（Q） 2015/05/19(火) 10:30

Dim A As Long
Dim LastRow As Long

LastRow = Range("A" & Rows.Count).End(xlUp).Row + 1
For A = 1 To Cells(Rows.Count, "A").End(xlUp).Row

        If Cells(A, "A").Value = Cells(1, 45) Then

        Cells(A, "B").Value = Cells(2, 45)
        Cells(A, "C").Value = Cells(3, 45)
        Cells(A, "D").Value = Cells(4, 45)

    End If
Next A

End Sub

このようなコードを書いてみたのですが
これだと条件にあった場所を探してその横のセルのBには一応反映されるのですが
空白行を見つけてどんどん書き溜めていきたいのに
その条件一致の一番上のセルのみ値が変更されていて
書き溜めれなくなってしまっています。
（Q） 2015/05/19(火) 10:36

こんな感じコードにしたかったのでしょうか。

 Sub test()
    Dim i As Long

    For i = 9 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(i, "A").Value = Cells(1, 45).Value Then
            If Cells(i, "A").Offset(, 1).Value = "" Then
                Cells(i, "B").Value = Cells(2, 45).Value
                Cells(i, "C").Value = Cells(3, 45).Value
                Cells(i, "D").Value = Cells(4, 45).Value
                Exit For
            End If
        End If
    Next i

 End Sub

（マナ） 2015/05/19(火) 21:08

 外出していてレス遅れました。

 >>コンパイルエラー？というものが一番最後のコードで出てしまいました…

 一番最後のコードとは、c.Offset(, 2).Value = Range("AS4").Value　のことですか？ 
 それとも End Sub でえすか？

 いずれもエラーにはなりえません。

 そうではなく　「シートモジュール」に貼り付けたコードのどこかでということですか？
 その場合、このコードで　どんなメッセージということを教えてほしいのですが、
 たとえば　ComboBox1 あるいは CommandButton1 がハイライトされ、「変数が定義されていません」というコンパイルエラーだったとか。

 で、もし、そうだったとしたら

 >>シートに ActiveX の ComboBox1 と　CommandButton1 を配置。

 と書きましたけど、それはやりましたか？

 あるいは、このコードはシートモジュールに書きますけど、それは大丈夫ですか？

（β） 2015/05/19(火) 21:44

ThisWorkbook モジュールとシートモジュールにいずれも分けてコードを記入しました。

実行時エラー　1004
WorksheetクラスのOLEObjectsプロパティを取得出来ません。

のエラーが出ています。

フォームコントロールのコンボボックスと図形の額縁をボタンに見立ててそこにマクロを
登録してボタンとして使用しています。
すみません、説明不足でした。
（Q） 2015/05/20(水) 09:52

 まずは フォームコントロールのコンボボックスと図形の額縁をやめて、ActiveXコントロールで試してみてください。

 動きが要件通りか誤解があるのかを確認してほしいので。

（β） 2015/05/20(水) 09:59

配置だけして試してみました。
上記と同じエラーがでてしまいました。
（AAA） 2015/05/20(水) 11:26

 同じ配置をしてもらっていればエラーにはなりません。

 まぁ、どこか違うんでしょうね。コントロールがどうこうより、

 >>A9:A28が結合、A29:A48が結合、・・ということでよろしいですね。
 >>どうも「とばし・・」という意味がわからないところもありますので、以下は誤解の産物かも。

 に対して確認をもらっていないので、処理ロジックそのものが要件にあっているのかどうか、それが不安ですが。

 ・ワークブックモジュールとシートモジュールのコードをすべて消してください。
 ・シートに挿入したActiveXコントロールも削除してください。
 ・以下のコードを【標準モジュール】にコピペしてください。
 　（Auto_Open のシート名とコンボボックスの名前は実際のものにしてください）
 ・そちらで、元々配置してあったフォームコントロールのコンボボックスに、"ComboClick" を、図形の額縁に、"BtnClick" をマクロ登録してください。
 ・ブックを一度保存して閉じて、再度、開いて試してください。

 Option Explicit

 Dim cb As DropDown

 Sub Auto_Open()
    Dim c As Range
    With Sheets("Sheet1")
        Set cb = .DrawingObjects("ドロップ 3")
        cb.List = ""
        cb.RemoveItem 1
        For Each c In .Range("A9", .Range("A" & .Rows.Count).End(xlUp))
            If Not IsEmpty(c) Then cb.AddItem c.Value
        Next
    End With
 End Sub

 Sub ComboClick()
    Range("AS1").Value = cb.List(cb.Value)
 End Sub

 Sub BtnClick()
    Dim z As Variant
    Dim c As Range
    Dim r As Range

    If cb.Value = 0 Then
        MsgBox "項目が選択されていません"
        Exit Sub
    End If
    z = Application.Match(cb.List(cb.Value), Range("A9", Range("A" & Rows.Count).End(xlUp)), 0)
    If IsError(z) Then
        MsgBox "項目が見つかりません"
        Exit Sub
    End If
    z = z + 8
    Set r = Range("A" & z).MergeArea
    Set r = r.Offset(, 1).Resize(r.Rows.Count)
    Set c = r.Find(What:=vbNullString, LookAt:=xlPart, LookIn:=xlFormulas, After:=r.Cells(r.Count))
    If c Is Nothing Then
        MsgBox "満杯です"
        Exit Sub
    End If
    c.Value = Range("AS2").Value
    c.Offset(, 1).Value = Range("AS3").Value
    c.Offset(, 2).Value = Range("AS4").Value
 End Sub

（β） 2015/05/20(水) 12:40

できました！！ありがとうございます！

できなかったら良いのですが、このボタンクリックで入力された値を
G2：K４に何月なのかをスピンボタンで指定していて
カレンダー形式で使っているのですが
月を変えると先ほどのコードで記入した開始日と終了日の月がG2:K4と同じ月のものを
どこかのシートに値をどんどんためていきそこから抽出する形で
先ほどのコードと同じ条件で月が変わると値も変わるようにできたりしますか？？
（Q） 2015/05/20(水) 13:05

 要件というか仕様が明確になればいかようにもお手伝いはしますが、(Q)さんは実際のシートを目で見ているというか
 それをもとに運用しているので当たり前のことでしょうけど、こちらは、どんなものが、どこに、どうセットされているか
 全くわからないですし、「どこかのシートに値をどんどんためていき」というのも、どこに、どのようにため込んでいくのか
 それがわからないと提案のしようもありません。
 「カレンダー形式で」といわれても、K2:G4がどんな形式（レイアウト）になっているのかもっわかりませんし
 「そこから抽出する形で 先ほどのコードと同じ条件で月が変わると値も変わるように」
 これも、具体的に何をどうしたいのか、不明です。

 関係する実際のレイアウトと、スピンボタンが押されたらどこに、何がどうなるかの実例、その結果で
 何をしたときに、どこをどこに転記したいか、その実例を具体的なサンプルで示してください。

 それと、スピンボタン処理をマクロでやっているならそのコードもアップしてください。

（β） 2015/05/20(水) 17:35

B2に項目　C2:F2項目 G2:K2項目
B3：B4に氏名　C3:F4に年 G3:K4に月(月と年はいづれもフォームコントロールのスピンボタンで表示切替）

N2:O2項目　P2:X2項目名を選ぶcomboBOX(こちらもフォームコントロールでBさんが教えてくださったコードが入ってます）
N4:O4項目　P4:X4内容を入力(セルに直接入力)
Z2:AA2項目　Ab2:AG2開始月を入力（セルに直接yyyy/mm/dd入力）
Z4:AA4項目　AB4:AG4終了月を入力（こちらも開始月同様）
Z4:AA4の横に図形の額縁をボタンとして配置、Bさんが教えてくださったコードが入っています。
ComboBOXからZ4:AA4までの入力したものをボタンを押すことによって
以下の場所に配置しています。

A7:D7空白(罫線で斜線入ってます）　E7からAJ7まで曜日が入ってます（=TEXT(E8,"aaa")の数式がAJ7まで）
A8空白　B8項目　C8項目(開始月）　D8項目（終了月) E8からAJ8まで日付（=DATE($C$3,$G$3,1)とE9以降は=E8+1をAJ8までコピー)
A9:A28に検索元になっている項目名（comboBOXで選択した値の検索値になってる）がA29:A48・・・・と20セルずつ縦に結合されていてA288まで
B9からB288までP4:X4に入力された内容が飛んでくる（条件一致でBさんのコード）
C9からC288までAB2:AG2に入力された開始の日付が飛んでくる（こちらも同様）
D9からD288までAB4:AG4に入力された終了日の日付が飛んでくる（同様）
E9からAJ9までは開始日と終了日を元にオートシェイプが引けるようになっています
E9から下も同様です。
こちらのコードが

Sub Sample()

     Dim rngStart As Range, rngEnd As Range
     Dim BX As Single, BY As Single, EX As Single, EY As Single
     Dim LastRow As Long, i As Long

     ActiveSheet.Lines.Delete
     LastRow = Cells(Rows.Count, 3).End(xlUp).Row

     For i = 9 To LastRow
         If Range("C" & i).Value = "" Or Range("D" & i).Value = "" Then
         Else
            Set rngStart = Range("C" & i).Offset(, Format(Range("C" & i).Value, "d") + 1)
            Set rngEnd = Range("D" & i).Offset(, Format(Range("D" & i).Value, "d"))

            BX = rngStart.Left
            BY = rngStart.Top
            EX = rngEnd.Left + rngEnd.Width
            EY = rngEnd.Top

            With ActiveSheet.Shapes.AddLine(BX, BY + 8, EX, EY + 8).Line
                 .ForeColor.RGB = vbRed
                 .Weight = 1.5
                 .EndArrowheadStyle = msoArrowheadTriangle
            End With
         End If
     Next

 End Sub

となっています。

これを万年カレンダーとしてスケジュール帳使用で使っていきたいので
C3:F4の年とG3:K4の月をスピンボタンで変えるごとに
B列の内容とC列、D列の日付も変わるようにしたいです。
スピンボタンで日付が変更された場合にオートシェイプもクリアされると助かります。
説明下手ですが伝わったでしょうか？
足りないところがあったらおっしゃってください。説明致します。

（Q） 2015/05/21(木) 09:32

 一生懸命読んで理解しようとしているのですが、なかなか、すんなりと頭に入ってきません。
 (理解力が年とともにどんどん低下しています）

 レイアウトの説明はいただきましたが、理解力不足を助けるために

 具体的なセル名と具体的な値を使い、この処理の最初から（たぶんスピンボタンで年をセットするところ？）
 から、最後（どこかに、何かをため込む？）まで、１件でいいので、シナリオというか、ストーリーを
 書いていただけませんか。

 ・○○することでセル■■に値▼▼がはいる。それをうけて、今度は・・・・・　といったように。

 ところで、基本的なことを１つ。

 この要件は、今まで対応してきたシートの処理に【追加】するのですか？
 それとも、今までのものとは全く別の、新規要件ということですか？

（β） 2015/05/21(木) 19:13

C3:F4に年 G3:K4に月の数字をフォームコントロールスピンボタンで反映させます。
例えば2015　5　なら
下の表の（A7:D7から始まる表）曜日から↓の部分が祝日や休日の色付けが変わる様になっています。
それを万年カレンダーとして使用していきたいので
Bさんが教えて下さったコードをマクロ登録してあるコンボボックスの部分から順に

例えば、コンボボックスの中の”みかん”を選ぶ
P4:X4に内容を入力。（セルに直接入力します）例えば、"売上を伸ばす"
Ab2:AG2に開始する日付けを入力（セルに直接）2015/5/1
AB4:AG4に終了の日付け（セルに直接）2015/5/25

これをBさんのコードの入ってる額縁ボタンを押すと
A9:A28にりんご
A29：A48にぶどう
A49：A68にみかん

（いづれも縦に文字が入力されています。）

コンボボックスの選んだ項目がみかんならA49:A68のみかんのところに
上記の値をB列から内容”売上を伸ばす"
C列に開始日付け　D列に終了日付け
E列に開始日から終了日までのオートシェイプがひかれるように現在なってます。

これをスピンボタン配置のところが
2015　6　になっていた場合は
上記の内容の表示がなくなり新たに開始日と終了日を６月分のものが表示されるようにしたいです。

今までのシートにこの要件を追加して万年スケジュール帳のような形で
使っていきたいとおもっています。

（Q） 2015/05/25(月) 10:33

 5/26 8:22 コメント、一部追加。

 ごめんなさい。やはり、私のプアな読解力では理解できませんでした。

 C2:F2 項目　といわれても、それはなに？　ですし、C2からF2まで４つのセルになにがしかの「項目」があるのか
 結合セルで、１つの「項目」があるのかもわかりません。（そもそも、「項目」というのが何かがわかりません）

 P2:X2 にコンボボックス　というのも同様で、長～～いコンボボックスが１つ配置されているのか、
 ９個のコンボボックスは配置されているのか？

 スピンボタンがマクロと連動しているのか、それとも、その書式設定項目だけで何か仕掛けがあるのかもわかりません。
 スピンボタンが１つだけあるのか、あるいは、もう、たくさんのスピンボタンが配置されているのかもわかりません。

 一生懸命説明いただいているのはわかるのですが、何をしたいのかということと、具体的にどんなシートなんだろうということが
 わからないんです。

 すでに対応した

 >>A列、A9からみかん、りんご、なしなどの項目が入っております。
 >>(A9～A28までセルが結合されていて縦書きで項目）

 >>同じシート内にコンボボックスで項目名を選ぶものと
 >>手書きで内容と開始日、終了日を記載してボタンを押すと
 >>コンボボックスで指定した項目名の空白行をみつけて
 >>上記内容を飛ぶようにしたいです。

 >>上記の内容はAS1に項目名、AS2に内容、AS3に開始日、AS4に終了日
 >>を一度飛ばし、そのあとボタン実行で各場所に飛ばしたいと思っています。

 というものとは、全く別物のシートなのか、これに、今回の要件も「追加するのか」
 それもわかりません。

 う～ん・・・・どうもお手伝いできそうにないですねぇ・・・・

 このトピ、もう、だいぶ進んでしまってますし、他の回答者さんが参加しにくくなっているかもしれません。
 いったん、ここは終わりにして、新しいトピを立ち上げ、そこで、まったく新規というか、最初から

 ・こんなレイアウト（含むコントロール）のシートがある。
 ・そこで、何をどうしたら、どこに、何を、どのように転記したい。

 こういうことを【だれが読んでも理解できるような形で】説明した上で、質問されてはいかがでしょうか。

（β） 2015/05/25(月) 20:07

新しいトピ開かせていただきます！ありがとうございました！
（Q） 2015/05/26(火) 10:06

コメント返信：

[ 一覧(最新更新順) ]

[[20150514132846]] 『VBAでの複数条件一致で値を抽出』（Q） ページの最後に飛ぶ

[[20150514132846]]　『VBAでの複数条件一致で値を抽出』（Q）　ページの最後に飛ぶ