Results of 1 - 1 of about 37667 for IF (0.008 sec.)
- [[20110716195114]]
- #score: 1591
- @digest: adfe2f848eccab870af9e28723d0f1a3
- @id: 55255
- @mdate: 2011-07-23T04:11:15Z
- @size: 41658
- @type: text/plain
- #keywords: inpcell (107399), 産地 (107289), outv (102184), myclass (97233), mycom (91833), outdic (78759), 別). (71074), getline (58194), datarow (50697), 番& (41013), 種別 (38046), myarea (28124), 品番 (24632), 索シ (21646), vbtab (17370), sheeta (15390), 索結 (14405), myrow (12232), pos (11774), 検索 (8328), string (6640), pattern (6319), の検 (6116), isnumeric (5935), 北海 (5909), ubound (5814), 種類 (4832), ん" (4630), 単価 (4318), sheets (4221), const (4211), columns (4057)
- 『複雑な検索』（ちーず）
いつもお世話になっております。 エクセルでここまでの検索が可能がどうか、 みなさまのお力をお借りしたくお願いいたします。 下記のようなデータから、他人が品番を入力しそれに対して 産地と種類を返したいのです。 (Excel2003) A B C D E F G 1 品番 産地1 産地2 産地3 種類1 種類2 種類3 2 キャベツ 北海道 青森 愛知 A10 B5 C8 3 たまねぎ 埼玉 茨城 青森 C12 B6 B3 4 レタス 山梨 北海道 高知 K3 C8 D12 5 にんじん 秋田 兵庫 鹿児島 L5 G9 B9 ●最初の検索 品番から産地と種類を検索 例＞キャベツと検索ボタンを押したら、A2〜G2まで結果を表示したい。 ●次の検索 上記の検索結果から次の候補みたいなボタンを押すと 最初の品番と同じ、産地と種類が一致するものを表示したい 例＞キャベツと同じ産地と種類を持つ品番はレタス（北海道とC8が合致） レタス、北海道、C8という検索結果を表示させたい。 ※データを変えられたくないので、 検索フォームは隣のワークシートでやろうと思っています。 VBAになりますでしょうか。。 よい方法があればご教授ください 宜しくお願いいたします ---- とりあえず最初の検索は、VBAじゃなくても、たとえばリストがSheet1にあったとして 検索シートのA1にキャベツ等をいれるとすれば、 B1 : =IF(ISERROR(VLOOKUP($A1,Sheet1!$A2:$G5,COLUMN(),0)),"",VLOOKUP($A1,Sheet1!$A2:$G5,COLUMN(),0)) で、これをG1までひっぱる。 次の検索は、関数素人の私には、関数で仕上げるのは無理なので、時間がとれればVBAで書いてみる。 その前に、関数エキスパートさん達から回答があると思うけど。 ぶらっと立ち寄り ---- VBAだけど、次の検索を。検索シートのA1にキャベツ等。 結果は検索シートの3行目以降に、該当のものを出力。 Sub 次の検索() Dim myCom As String Dim ans As Variant Dim v As Variant Dim outV() As String Dim x As Long, y As Long, i As Long, k As Long Dim myArea As String, myClass As String myCom = Sheets("検索").Range("A1").Value v = Sheets("Sheet1").Range("A1").CurrentRegion.Value ReDim outV(1 To UBound(v, 1) * 9, 1 To 3) ans = Application.Match(myCom, WorksheetFunction.Index(v, 0, 1), 0) If Not IsNumeric(ans) Then MsgBox "品番がありません" Else For i = 2 To UBound(v, 1) If i <> ans Then For x = 2 To 4 myArea = v(ans, x) If Len(myArea) > 1 And IsNumeric(Application.Match(myArea, Array(v(i, 2), v(i, 3), v(i, 4)), 0)) Then For y = 5 To 7 myClass = v(ans, y) If Len(myClass) > 1 And IsNumeric(Application.Match(myClass, Array(v(i, 5), v(i, 6), v(i, 7)), 0)) Then k = k + 1 outV(k, 1) = v(i, 1) outV(k, 2) = myArea outV(k, 3) = myClass End If Next End If Next End If Next Sheets("検索").Range("A3").Resize(UBound(outV, 1), UBound(outV, 2)).Value = outV End If End Sub ぶらっと立ち寄り ---- 最初の検索の式、見つからなかったらエラーを表示させた方がいいね。 B1 : =IF($A1="","",VLOOKUP($A1,Sheet1!$A2:$G5,COLUMN(),0)) にしよう。 ぶらっと立ち寄り ---- ぶらっと立ち寄りさま 早速ありがとうございました! 最初の検索出来ました! ですが、次の検索がうまく動きません。 ”次の検索”というボタンを作成して、 VBAを入れてみましたが”品番がありません”とでてしまいました。 私がどこか絶対間違えてると思うのですが…（--;） また、上記表では簡単に書いているのですが 実は、種類と産地で各30行以上データがあり、今後も増える予定です。 種類と産地でSheetをわけています。 最初の検索も、かなり横に長い検索結果になるので 他にいい方法があればお願いします。 よろしくおねがいします（vv） ---- 次の検索 は、実行時にA1にキャベツなんかが入っているというコードだけど、それは大丈夫? 一応、こちらでは動いているのでシートレイアウトで正しく理解していないところがあるのかな? 種類と産地でシートをわけているっていうのが気になるけど? でも、関数は動いたんだよね? 第二がVBAなので第一の検索もVBAで統一・・というか、一つのマクロで両方カバーしたほうが 操作の上からも自然なので、統合版のコードをかいてみるけど、その前に、アップしたコードが、ちゃんと 動かなきゃね。 追記）全てのシートのシートレイアウトをもう一度説明してくれる? ここの列は増減するとか、ここの行は増減するということは、もちろんOK。 ぶらっと立ち寄り ---- 「最初の検索も、かなり横に長い検索結果になるので」「種類と産地でSheetをわけています」 ということで、上で聞いているシートレイアウトの再説明をしてもらってからのほうがいいとはおもうけど とりあえず、現在アップされているレイアウトのままで。 検索シートの A1 に品番を入力すると B1〜G1に最初の検索結果を、またA3以降の行に次の検索結果を表示。 なお、コードは、標準モジュールではなく検索シートのシートモジュールに貼り付け。 （検索シートのシートタブを右クリックしてコードの表示を選ぶ） それと、コードとは関係がないけど、品番をいれるセル（コードではA1）には入力規則を設定しておいた方が便利かも。 Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A1")) Is Nothing Then Application.EnableEvents = False If Len(Range("A1").Value) = 0 Then 検索結果のクリア Else 最初と次の検索 End If Application.EnableEvents = True End If End Sub Private Sub 最初と次の検索() Dim myCom As String Dim ans As Variant Dim v As Variant Dim outV() As String Dim x As Long, y As Long, i As Long, k As Long Dim myArea As String, myClass As String myCom = Range("A1").Value v = Sheets("Sheet1").Range("A1").CurrentRegion.Value ReDim outV(1 To UBound(v, 1) * 9, 1 To 3) ans = Application.Match(myCom, WorksheetFunction.Index(v, 0, 1), 0) If Not IsNumeric(ans) Then MsgBox "品番がありません" 検索結果のクリア Else Range("B1:G1").Value = Sheets("Sheet1").Cells(ans, 2).Resize(, 6).Value For i = 2 To UBound(v, 1) If i <> ans Then For x = 2 To 4 myArea = v(ans, x) If Len(myArea) > 1 And IsNumeric(Application.Match(myArea, Array(v(i, 2), v(i, 3), v(i, 4)), 0)) Then For y = 5 To 7 myClass = v(ans, y) If Len(myClass) > 1 And IsNumeric(Application.Match(myClass, Array(v(i, 5), v(i, 6), v(i, 7)), 0)) Then k = k + 1 outV(k, 1) = v(i, 1) outV(k, 2) = myArea outV(k, 3) = myClass End If Next End If Next End If Next Range("A3").Resize(UBound(outV, 1), UBound(outV, 2)).Value = outV End If End Sub Private Sub 検索結果のクリア() Range("B1:G1").ClearContents Range("A3", Range("A3").End(xlDown)).Resize(, 3).ClearContents End Sub ぶらっと立ち寄り ---- 早速、ありがとうございます（^-^） 産地と種類"sheet1"という名前でとりあえず一緒にしてやってみました! A1に品番をいれると、一瞬で"品番がありません"と メッセージがでてしまいます（TT） 今のシートの状態ですが シート名＜Sheet1＞ B5〜CB90・・・品番、 C5〜C90・・・単価、 D5〜BA90・・・産地、 BB5〜CP90・・種類、 シート名＜検索＞ VBAが入っています。 ここのエクセルシートは、まっさらの状態です。 本当は検索ボタンなどつけたいのですが・・・ できないのに、いろいろもーしわけございません。 どうぞよろしくおねがいします。 ---- 間違えたところがあるので、訂正いたします。 シート名＜Sheet1＞B5〜B90・・・品番 検索というシートに入っているのは 教えていただいた部分にセルのところを直しました。 ご指摘おねがいたします。 ------------------------------------------------------------ Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A1")) Is Nothing Then Application.EnableEvents = False If Len(Range("A1").Value) = 0 Then 検索結果のクリア Else 最初と次の検索 End If Application.EnableEvents = True End If End Sub Private Sub 最初と次の検索() Dim myCom As String Dim ans As Variant Dim v As Variant Dim outV() As String Dim x As Long, y As Long, i As Long, k As Long Dim myArea As String, myClass As String myCom = Range("A1").Value v = Sheets("Sheet1").Range("B5").CurrentRegion.Value ReDim outV(1 To UBound(v, 1) * 9, 1 To 3) ans = Application.Match(myCom, WorksheetFunction.Index(v, 0, 1), 0) If Not IsNumeric(ans) Then MsgBox "品番がありません" 検索結果のクリア Else Range("D5:CP90").Value = Sheets("Sheet1").Cells(ans, 2).Resize(, 6).Value For i = 2 To UBound(v, 1) If i <> ans Then For x = 2 To 4 myArea = v(ans, x) If Len(myArea) > 1 And IsNumeric(Application.Match(myArea, Array(v(i, 2), v(i, 3), v(i, 4)), 0)) Then For y = 5 To 7 myClass = v(ans, y) If Len(myClass) > 1 And IsNumeric(Application.Match(myClass, Array(v(i, 5), v(i, 6), v(i, 7)), 0)) Then k = k + 1 outV(k, 1) = v(i, 1) outV(k, 2) = myArea outV(k, 3) = myClass End If Next End If Next End If Next Range("A3").Resize(UBound(outV, 1), UBound(outV, 2)).Value = outV End If End Sub Private Sub 検索結果のクリア() Range("D5:CP90").ClearContents Range("A3", Range("A3").End(xlDown)).Resize(, 3).ClearContents End Sub ---- >シート名＜Sheet1＞B5〜CB90・・・品番、 C5〜C90・・・単価、 D5〜BA90・・・産地、 BB5〜CP90・・種類、 ひゃ〜!! 最初にアップされたレイアウトでは1行目がタイトル行で、A列が品番で、B〜D列が産地で、E〜G列が種類じゃなかった? 直前で、どなたかがコードをアップしてくれているけど、これは、チーズさんがアップ? 追記）いずれにしても、レイアウトが大幅に変わっているので、コードもかなり手を入れなきゃいけない。 なるべく、時間をとってアップしたいけど、もしかしたら明日になるかも。 さらに追記） >産地と種類"sheet1"という名前でとりあえず一緒にしてやってみました とりあえずということは、本来は別のシートなんだろうから、二度手間になるのを避けるため 本来のそれぞれのシート名と、そのレイアウトを教えて。 ぶらっと立ち寄り ---- あのー、 Sheet1のA列はどうなっているのでしょう? 削除できるのなら、削除してもらった方がコードが書きやすいのですが? (seiya) それと、同シートの 1-4 行は何かあるのでしょうか? ---- えっとですね。 A列は何も入っていなので削除できます。 1〜4行もタイトル、項目名が入っているだけなので削除できます。 これら削除しちゃった方がいいでしょうか? ---- それでは、別シート(仮にSheetA)に全てをコピーして作業しましょう。 A列は削除 1-4行の間で空白行はありませんか? (seiya) ---- 1行目（B1セル）がタイトル、 2、3行目が空白行になっています。 4行目に項目が入っています。 メンテする人が使わないシートなので、 項目だけ残して消した方がいいですか? ---- >メンテする人が使わないシートなので、 項目だけ残して消した方がいいですか? そのようにして下さい。 原則としてリスト内には、空白行・列は存在させないようにしてください。 1行目がタイトル行で2行目以下がデータということで書き始めますが、 もう一度、変更後の項目列を教えてください。 (seiya) ---- いろいろご面倒おかけします。 変更後ですが・・・ ＜行＞ 1行目が項目、2行目からがデータ（実際には86行ありました） ＜列＞ A列が品番、B列が単価、C列〜AZ列まで産地、BA列〜CO列までが種類 いま確認したところ 品番、単価は入っていますが、産地種類が1つも入ってない場合もありました。 また列、行も追加削除する場合があるのですが 大丈夫でしょうか? よろしくおねがいします ---- >いま確認したところ 品番、単価は入っていますが、産地種類が1つも入ってない場合もありました。 それは、そのままで結構です。 全て確認しました。 (seiya) ---- いろいろお手数おかけします（;;） よろしくおねがいします! ---- よく検証してきませんが、 検索シートにコマンドボタンを二つ(CommandButton1/CommandeButton2) を配置してください。 検索シートのモジュールへ Option Explicit Private flg As Boolean, myRow(), RegX As Object Private Sub CommandButton1_Click() Dim r As Range Set r = Sheets("sheeta").Columns(1).Find(Range("a1").Value, , , xlWhole) If Not r Is Nothing Then r(1, 2).Resize(, 92).Copy Range("b1") Application.CutCopyMode = False ReDim myRow(0): myRow(0) = r.Row flg = True Else MsgBox "データはありません" End If End Sub Private Sub CommandButton2_Click() Dim myPtn1 As String, a, i As Long, ii As Long, temp As String, x As Long Dim myPtn2, myPtn, msg, temp1, temp2 If Not flg Then Exit Sub x = UBound(myRow) myPtn1 = Check_Ptn(Join$([transpose(transpose(b1:az1))], "|")) If Len(Replace(myPtn1, "|", "")) = 0 Then _ msg = "産地がありません" & vbLf myPtn2 = Check_Ptn(Join$([transpose(transpose(ba1:co1))], "|")) If Len(Replace(myPtn2, "|", "")) = 0 Then _ msg = msg & "種類がありません" If Len(msg) Then MsgBox msg Erase myRow: flg = False Exit Sub End If myPtn = ";;(" & myPtn1 & ");;.*;;(" & myPtn2 & ");;" a = Sheets("sheeta").Range("a1").CurrentRegion.Value2 With CreateObject("VBScript.RegExp") .Pattern = myPtn For i = 2 To UBound(a, 1) If a(i,1) = Range("a1").Value Then If IsError(Application.Match(i, myRow, 0)) Then For ii = 2 To 52 If a(i, ii) <> "" Then temp1 = temp1 & ";;" & a(i, ii) End If Next If Len(temp1) Then For ii = 53 To UBound(a, 2) If a(i, ii) <> "" Then temp2 = temp2 & ";;" & a(i, ii) End If Next If Len(temp2) Then temp = temp1 & ";" & temp2 & ";;" .Pattern = myPtn If .test(temp) Then Sheets("sheeta").Rows(i).Resize(, UBound(a, 2)).Copy _ Cells(Rows.Count, 1).End(xlUp)(2) ReDim Preserve myRow(UBound(myRow) + 1) myRow(UBound(myRow)) = i Exit For End If End If End If End If End If temp = "" If x <> UBound(myRow) Then Exit For Next End With If UBound(myRow) = x Then MsgBox "データはありません" Erase myRow: flg = False End If End Sub Private Function Check_Ptn(txt As String) As String If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp") With RegX .Pattern = "¥|{2,}" .Global = True txt = .Replace(txt, "|") .Pattern = "¥|$" txt = .Replace(txt, "") End With Check_Ptn = txt End Function (seiya) ---- ありがとうございます!すごいですね!! コマンドボタンを作って実行してみたところ コマンド1のボタンでA1にりんごと入力すると りんご a625 a626 a627 a628 という結果がでて（^0^）/ コマンド2のボタンを押すと 品番とa62 a63 という違う結果がでてきました(TT） 何回かコマンド2のボタンを押してみましたが 一致する品番がでてきませんでした。 ここまですごいのができたので、何とか完成を見てみたいのですが・・・ 追加のお願いで申し訳ないのですが 品番や単価、種類など項目をのせることはできますか? 種類、産地のデータが似た数字と英字の組み合わせなので 見分けができればなと思いました。 終わったあとのクリアボタンなどもあると助かります（vv;） いろいろわがまま言ってすみません・・・ ---- B列の単価が安い順にだすこともできますでしょうか（＞＜）? ---- > B列の単価が安い順にだすこともできますでしょうか（＞＜）? これはSheetAをB列で昇順に並べ替えしておけば、よいでしょう。 あとは、何分こちらでは検証できませんので、実際にファイルを見ること が出来ないと難しいですね。 (seiya) ---- ありがとうございます♪ ファイルをお見せしてもいいのですが、 どのような方法でファイルをのせられますか? ---- CommandButton2 のコードを少々変更しましたので、試してください。 (seiya) ---- 早速やってみましたが、今度はどの品番に対しても "データがありません"となってしまいます。。 あと検索結果が空白セルを含めてCO列まで罫線と一緒に でてしまうのはしょうがないことでしょうか? 検索結果が10個ぐらいなのに、 だいぶ横にスクロールしないと結果が見れないので残念なのですが（;;） ---- 一か所タイプミスがありました。 まず、データが正確に抽出できるかどうかを確認しましょう。 (seiya) ---- seiyaさま できましたーーー!! でも次の検索をすると、りんごと一致してないところもでてきます。 ばななのSbj2、Sbj6です〜〜（＞＜） 品番 単価 りんご 50.00 Sa52 Sa56 Sa62 Sa66 W475⇒最初めの検索 ばなな 60.00 Sa62 Sa66 Sbj2 Sbj6 W475⇒次の検索 ---- > 最初の品番と同じ、産地と種類が一致するものを表示したい。 ^^^^^^^^^^^^^^^^ 見逃していました。 もう一度試してください。 (seiya) ---- 今度はどの品番でも "データはありません"になってしまいましたぁ。。（;;） ---- 以前のコードで品番が違った対象データが抽出されて、今回はできないということは 品番の同じものがない可能性があります。 余計なスペース等入っていませんか? (seiya) ---- とりあえずTrim関数で試してみましょう 1) CommandButton3 を追加(消去用) 2) 検索シートの3行目にSheetAの一行目の項目見出しをコピーする。 3) 検索品番はA4に入力 としてください。 Option Explicit Private flg As Boolean, myRow(), RegX As Object Private Sub CommandButton1_Click() Dim r As Range Set r = Sheets("sheeta").Columns(1).Find(Range("a4").Value, , , xlWhole) If Not r Is Nothing Then Range("b4").Resize(, 92).Value = r(1, 2).Resize(, 92).Value Application.CutCopyMode = False ReDim myRow(0): myRow(0) = r.Row flg = True Else MsgBox "データはありません" End If End Sub Private Sub CommandButton2_Click() Dim myPtn1 As String, a, i As Long, ii As Long, temp As String, x As Long Dim myPtn2, myPtn, msg, temp1, temp2 If Not flg Then Exit Sub x = UBound(myRow) myPtn1 = Check_Ptn(Join$([transpose(transpose(b4:az4))], "|")) If Len(Replace(myPtn1, "|", "")) = 0 Then _ msg = "産地がありません" & vbLf myPtn2 = Check_Ptn(Join$([transpose(transpose(ba4:co4))], "|")) If Len(Replace(myPtn2, "|", "")) = 0 Then _ msg = msg & "種類がありません" If Len(msg) Then MsgBox msg Erase myRow: flg = False Exit Sub End If myPtn = ".*;;(" & myPtn1 & ");;.*;;(" & myPtn2 & ");;.*" a = Sheets("sheeta").Range("a1").CurrentRegion.Value2 With CreateObject("VBScript.RegExp") .Pattern = myPtn For i = 2 To UBound(a, 1) If Trim(a(i, 1)) = Trim(Range("a4").Value) Then If IsError(Application.Match(i, myRow, 0)) Then For ii = 2 To 52 If a(i, ii) <> "" Then temp1 = temp1 & ";;" & a(i, ii) End If Next If Len(temp1) Then For ii = 53 To UBound(a, 2) If a(i, ii) <> "" Then temp2 = temp2 & ";;" & a(i, ii) End If Next If Len(temp2) Then temp = temp1 & ";" & temp2 & ";;" .Pattern = myPtn If .test(temp) Then Sheets("sheeta").Rows(i).Resize(, UBound(a, 2)).Copy _ Cells(Rows.Count, 1).End(xlUp)(2) ReDim Preserve myRow(UBound(myRow) + 1) myRow(UBound(myRow)) = i Exit For End If End If End If End If End If temp1 = "": temp2 = "" temp = "" If x <> UBound(myRow) Then Exit For Next End With If UBound(myRow) = x Then MsgBox "データはありません" Erase myRow: flg = False End If End Sub Private Function Check_Ptn(txt As String) As String If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp") With RegX .Pattern = "¥|{2,}" .Global = True txt = .Replace(txt, "|") .Pattern = "¥|$" txt = .Replace(txt, "") End With Check_Ptn = txt End Function Private Sub CommandButton3_Click() Range("a3").CurrentRegion.Offset(1).ClearContents Erase myRow flg = False End Sub (seiya) ---- seiyaさんに登場いただき、コードも大詰めになってきたようだね。 ここで、また違ったコードを提案すると、ちーずさんも混乱しそうなので、しばらくはROMでいきます。 テーマとしてはおもしろそうなので、seiyaさんとは違った構成のコードを書いてみるつもりだけど。 列が大幅に増えたので、照合型0のMatchでは、荷が重すぎるね。さて、何を使うか。 ぶらっと立ち寄り ---- Seiyaさん、ぶらっとさん いろいろありがとうございます（^^） 早速自宅へ帰ったので、やってみようと思ったのですが 自宅PCはexcel2007なのでマクロが無効というメッセージが でて使用できません（TT） オプションで無効を有効にしてるんですが・・・ 早くやりたくてウズウズです。 ---- xlsm で保存しましたか? (seiya) ---- はい・・・↓ エクセルのアイコンもビックリマークのようなものがついているのですが オプションのところも"すべてのマクロを有効にする"に チェックが入っているので、何がダメなのかわかりません。 もうかれこれ1時間ほど格闘してます笑 2007でVBAをやるのは初めてで、もたついてすみません。。泣） 明日会社でまたやります（^^） ---- おはようございます。 早速やってみました! 今の時点で気がついたところです。 @コマンドボタン2ですが、同じ品番があるのに "データはありません"となります。 Aコマンドボタン3の消去ですが、全部行をクリアにしたいのですが 品番しか消えません。。 B項目列なのですが、産地、種類のところは項目ではなく 下記のようにそれぞれの名前が項目になっています。 それなので、どれが産地で種類かはこのデータでは見分けがつかない状態です。 C結果がCO列まで表示されてしまいます。 ----------------------------------------------- <SheetA>の状態です （うまく表がはれなくてすみません;） 品番 単価 a52 a62 a66 a67⇒項目列 りんご 10 a62 a66 ばなな 20 みかん 30 a62 a67 キュウイ 10 パイン 20 a62 a66 グレープ 30 a52 a62 a66 イヨカン 10 a52 a62 a67 ---- うーーーん まったくわかりません。 それらしい小さなデータを作って確認していますが、こちらではでてきますけど? (seiya) ---- （￣□￣;）!!ガー--ン もう一度見直してみます! ---- 一応書いたのでアップ。seiyaさんのコードが一段落して時間があれば試してみて。 seiyaさんのコードと同じマクロブックで動かせるように、以下のコードは全て標準モジュール。 フォームツールのボタンを配置して、最初の検索、次の検索、検索領域クリア を登録。 seiyaさんのコードと同じく、検索シートの A4 に品番をいれて実行。 最初の検索結果はB4以降の4行目に産地まで、C5以降の5行目に種別を。 また次の検索結果は7行目以降に表示。 なお、コートとしては、産地、種別、それぞれ、間に空白セルがあっても対応しているが これが全て左詰ということであれば、もう少し実行時間は短縮できる。 また、たとえば キャベツ が 北海道、栃木 で AA、BB だったとして セロリも 北海道、栃木 で AA、BB だった場合、次の検索結果として セロリ 北海道 AA セロリ 北海道 BB セロリ 栃木 AA セロリ 栃木 BB と4つ抽出している。もし、最初に見つかったもののみ代表で セロリ 北海道 AA と1つのみ抽出でよければ、seiyaさんのコードのように正規表現を使うほうがスッキリし、かつ 処理時間も短縮できるとおもう。 シートレイアウト等で、まだ勘違いしているところもあるかも。 シートレイアウトで主要なところは、最初のConstで規定しているので、実際のレイアウトと異なれば このあたりをなおしてみて。 Option Explicit 'リストのあるシートの規定 Const shnL As String = "Sheeta" 'シート名 Const dataRow As Long = 6 'データは6行目からはじまる Const pos品番 As String = "A" Const pos産地 As String = "C" Const end産地 As String = "AZ" Const pos種別 As String = "BA" Const end種別 As String = "CO" '検索シートの規定 Const shnE As String = "検索" 'シート名 Const inpCell As String = "A4" '検索品番入力セル Const outCell As String = "A7" '次の検索結果の出力開始位置 Sub 最初の検索() Dim myCom As String Dim x As Long, z As Long, len1 As Long, len2 As Long myCom = Sheets(shnE).Range(inpCell) 検索結果クリア z = getLine(myCom) If z > 0 Then len1 = Columns(end産地).Column - Columns(pos品番).Column + 1 len2 = Columns(end種別).Column - Columns(pos種別).Column + 1 x = Columns(pos品番).Column With Sheets(shnE) .Range(inpCell).Resize(, len1).Value = Sheets(shnL).Cells(z, x).Resize(, len1).Value .Range(inpCell).Offset(1, 2).Resize(, len2).Value = Sheets(shnL).Cells(z, pos種別).Resize(, len2).Value End With End If End Sub Sub 次の検索() Dim myCom As String Dim myArea As String Dim myClass As String Dim v() As Variant Dim w As Variant Dim x As Long, y As Long, z As Long Dim i As Long, j As Long, k As Long Dim c As Range Dim outDic As Object Dim dicidx As Long myCom = Sheets(shnE).Range(inpCell) Sheets(shnE).Range(outCell).CurrentRegion.ClearContents z = getLine(myCom) If z = 0 Then Exit Sub Set outDic = CreateObject("Scripting.Dictionary") With Sheets(shnL) y = .Range(pos品番 & .Rows.Count).End(xlUp).Row 'マッチング用配列の生成 ReDim v(1 To y - dataRow + 1, 1 To 4) For Each c In .Range(pos品番 & dataRow & ":" & pos品番 & y) x = c.Row k = k + 1 v(k, 1) = c.Value '品番 v(k, 2) = c.Offset(, 1).Value '単価 w = .Range(.Cells(x, pos産地), .Cells(x, end産地)).Value w = vbTab & Join(WorksheetFunction.Index(w, 1, 0), vbTab) & vbTab v(k, 3) = w w = .Range(.Cells(x, pos種別), .Cells(x, end種別)).Value w = vbTab & Join(WorksheetFunction.Index(w, 1, 0), vbTab) & vbTab v(k, 4) = w Next 'マッチング開始 For i = Columns(pos産地).Column To Columns(end産地).Column myArea = .Cells(z, i).Value If Len(myArea) > 0 Then For j = Columns(pos種別).Column To Columns(end種別).Column myClass = .Cells(z, j).Value If Len(myClass) > 0 Then For k = 1 To UBound(v, 1) If v(k, 1) <> myCom Then If InStr(v(k, 3), vbTab & myArea & vbTab) > 0 Then If InStr(v(k, 4), vbTab & myClass & vbTab) > 0 Then dicidx = dicidx + 1 outDic(dicidx) = Array(v(k, 1), v(k, 2), myArea, myClass) End If End If End If Next End If Next End If Next End With If outDic.Count = 0 Then MsgBox "抽出ゼロ件でした" Else '抽出結果の表示と並び替え Application.ScreenUpdating = False With Sheets(shnE).Range(outCell).Resize(outDic.Count, UBound(v, 2)) .Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(outDic.items)) .Sort Key1:=Range("B7"), Order1:=xlAscending, Key2:=Range("A7"), _ Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom, SortMethod:=xlPinYin End With Application.ScreenUpdating = True MsgBox "抽出が終わりました" End If Set outDic = Nothing End Sub Sub 検索結果クリア() Dim myCom As String With Sheets(shnE) myCom = .Range(inpCell).Value .Cells.ClearContents .Range(inpCell).Value = myCom End With End Sub Private Function getLine(myCom As String) As Long Dim z As Variant With Sheets(shnL) If Len(myCom) = 0 Then MsgBox "品番が入力されていません" Else z = Application.Match(myCom, .Columns(pos品番), 0) If IsNumeric(z) Then getLine = z Else MsgBox "品番が見あたりません" End If End If End With End Function ぶらっと立ち寄り ---- ↑ いままでのやりとりをよく読むと最終的には、リストはタイトルが1行目でデータが2行目だね。 Const dataRow As Long = 2 'データは2行目からはじまる このように直してくださいね。 ぶらっと立ち寄り ---- ぶらっと立ち寄りさま ずっと見てていただいてありがとうございます☆ 教えていただいたやり方でためしてみたところ できました〜（^0^） ただ"次の検索"で同じ品番で内容の違うものがあると 同じ品番だけで10件ぐらい並んでしまい、 全部で90行ほどの結果がでてしまいました。 できれば1品番1行でできるといいのですが（＞＜） ---- >できれば1品番1行でできるといいのですが ・同じ品番を1行にまとめて表示 ・代表して最初に見つかった組合せだけを表示 どっちがいいですか? ぶらっと立ち寄り ---- とりあえず、見つかった最初の組合せのみ代表で表示するパターン。 マッチングは正規表現を使い、前にアップしたものよりチェックのループを減らした。 以下の 次の検索 を 差し替え。getPtn を 追加。 そのほかは変更なし。 Sub 次の検索() Dim myCom As String Dim myArea As String Dim myClass As String Dim v() As Variant Dim w As Variant Dim x As Long, y As Long, z As Long Dim i As Long, j As Long, k As Long Dim c As Range Dim outDic As Object Dim dicidx As Long Dim pat産地 As String Dim pat種別 As String Dim myRE As Object Dim ex産地 As Object Dim ex種別 As Object myCom = Sheets(shnE).Range(inpCell) Sheets(shnE).Range(outCell).CurrentRegion.ClearContents z = getLine(myCom) If z = 0 Then Exit Sub pat産地 = getPtn(z, pos産地, end産地) pat種別 = getPtn(z, pos種別, end種別) If Len(pat産地) = 0 Or Len(pat産地) = 0 Then MsgBox "産地、種別の情報がないので検索できません" Exit Sub End If Set outDic = CreateObject("Scripting.Dictionary") Set myRE = CreateObject("VBScript.RegExp") myRE.Global = True '文字列全体を検索 With Sheets(shnL) y = .Range(pos品番 & .Rows.Count).End(xlUp).Row 'マッチング用配列の生成 ReDim v(1 To y - dataRow + 1, 1 To 4) For Each c In .Range(pos品番 & dataRow & ":" & pos品番 & y) x = c.Row k = k + 1 v(k, 1) = c.Value '品番 v(k, 2) = c.Offset(, 1).Value '単価 w = .Range(.Cells(x, pos産地), .Cells(x, end産地)).Value w = vbTab & Join(WorksheetFunction.Index(w, 1, 0), vbTab) & vbTab v(k, 3) = w w = .Range(.Cells(x, pos種別), .Cells(x, end種別)).Value w = vbTab & Join(WorksheetFunction.Index(w, 1, 0), vbTab) & vbTab v(k, 4) = w Next 'マッチング開始 For k = 1 To UBound(v, 1) If v(k, 1) <> myCom Then myRE.Pattern = pat産地 Set ex産地 = myRE.Execute(v(k, 3)) myRE.Pattern = pat種別 Set ex種別 = myRE.Execute(v(k, 4)) If ex産地.Count > 0 And ex種別.Count > 0 Then dicidx = dicidx + 1 outDic(dicidx) = Array(v(k, 1), v(k, 2), ex産地(0).Value, ex種別(0).Value) End If End If Next End With If outDic.Count = 0 Then MsgBox "抽出ゼロ件でした" Else '抽出結果の表示と並び替え Application.ScreenUpdating = False With Sheets(shnE).Range(outCell).Resize(outDic.Count, UBound(v, 2)) .Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(outDic.items)) .Sort Key1:=Range("B7"), Order1:=xlAscending, Key2:=Range("A7"), _ Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom, SortMethod:=xlPinYin End With Application.ScreenUpdating = True MsgBox "抽出が終わりました" End If Set outDic = Nothing Set myRE = Nothing Set ex産地 = Nothing Set ex種別 = Nothing End Sub Private Function getPtn(myRow As Long, posData As String, posEnd As String) As String Dim w As Variant Dim s As String Dim c As Range Dim sep As String sep = "" With Sheets(shnL) For Each c In .Range(.Cells(myRow, posData), .Cells(myRow, posEnd)) If Len(c.Value) > 0 Then s = s & sep & c.Value sep = vbTab & "|" & vbTab End If Next If Len(s) > 0 Then getPtn = "(" & vbTab & s & vbTab & ")" End If End With End Function ぶらっと立ち寄り ---- こんにちは! やってみました! 代表の方が、スッキリしてて見やすいですね! ただそれをもとに倉庫へ在庫を見にいくので、 代表ものがなかった場合、次の候補の検索をしなくてはなりません。。 たまに、産地が違うのに種別が一致してるものも拾ってきます。 最初の検索ですが、 ここも空白を削除してつめることは可能でしょうか? 検索後、画面に何もでてないときがあり 一瞬、産地も種別もがないのかな。と思うと ずっと右の列にスクロールするとあったりします（^^） でもここまでできれば、もう完成に近い感じがします♪ ---- >最初の検索ですが、ここも空白を削除してつめることは可能でしょうか? うん、できるよ。 >代表ものがなかった場合、次の候補の検索をしなくてはなりません。。 たとえば抽出された品番の行の最初のほうに、検索元とおなじ産地を左詰で、その後に検索元と同じ種別を左詰で。 こんなことはできると思うけど。 それより、【たまに、産地が違うのに種別が一致してるものも拾ってきます。】 もし、こうなったとしたらバグだけど、そうなるの? ぶらっと立ち寄り ---- 一応簡単なテストはしてあるけど試してみて。 ・最初の検索、産地、種別を前詰めに。 ・次の検索、品番ごとに1行だけど、検索元と同じ産地、種別を一行に列挙。これも前詰め。 コード、フルセットアップするので、全てリバイスしてね。 Option Explicit 'リストのあるシートの規定 Const shnL As String = "Sheeta" 'シート名 Const dataRow As Long = 2 'データは2行目からはじまる Const pos品番 As String = "A" Const pos産地 As String = "C" Const end産地 As String = "AZ" Const pos種別 As String = "BA" Const end種別 As String = "CO" '検索シートの規定 Const shnE As String = "検索" 'シート名 Const inpCell As String = "A4" '検索品番入力セル Const outCell As String = "A7" '次の検索結果の出力開始位置 Sub 最初の検索() Dim myCom As String Dim x As Long, z As Long, len1 As Long, len2 As Long myCom = Sheets(shnE).Range(inpCell) 検索結果クリア z = getLine(myCom) If z > 0 Then len1 = Columns(end産地).Column - Columns(pos品番).Column + 1 len2 = Columns(end種別).Column - Columns(pos種別).Column + 1 x = Columns(pos品番).Column With Sheets(shnE) .Range(inpCell).Resize(, len1).Value = 前詰め(Sheets(shnL).Cells(z, x).Resize(, len1)) .Range(inpCell).Offset(1, 2).Resize(, len2).Value = 前詰め(Sheets(shnL).Cells(z, pos種別).Resize(, len2)) End With End If End Sub Sub 次の検索() Dim myCom As String Dim myArea As String Dim myClass As String Dim v() As Variant Dim w As Variant Dim x As Long, y As Long, z As Long Dim i As Long, j As Long, k As Long Dim c As Range Dim pat産地 As String Dim pat種別 As String Dim myRE As Object Dim ex産地 As Object Dim ex種別 As Object Dim outV() As String Dim len1 As Long, len2 As Long, cnt As Long Dim exWk As Object myCom = Sheets(shnE).Range(inpCell) Sheets(shnE).Range(outCell).CurrentRegion.ClearContents z = getLine(myCom) If z = 0 Then Exit Sub pat産地 = getPtn(z, pos産地, end産地) pat種別 = getPtn(z, pos種別, end種別) If Len(pat産地) = 0 Or Len(pat産地) = 0 Then MsgBox "産地、種別の情報がないので検索できません" Exit Sub End If Set myRE = CreateObject("VBScript.RegExp") myRE.Global = True '文字列全体を検索 With Sheets(shnL) y = .Range(pos品番 & .Rows.Count).End(xlUp).Row '出力用配列の初期化 len1 = Columns(end産地).Column - Columns(pos品番).Column + 1 len2 = Columns(end種別).Column - Columns(pos種別).Column + 1 ReDim outV(1 To y - dataRow + 1, 1 To len1 + len2 + 3) 'マッチング用配列の生成 ReDim v(1 To y - dataRow + 1, 1 To 4) For Each c In .Range(pos品番 & dataRow & ":" & pos品番 & y) x = c.Row k = k + 1 v(k, 1) = c.Value '品番 v(k, 2) = c.Offset(, 1).Value '単価 w = .Range(.Cells(x, pos産地), .Cells(x, end産地)).Value w = vbTab & Join(WorksheetFunction.Index(w, 1, 0), vbTab) & vbTab v(k, 3) = w w = .Range(.Cells(x, pos種別), .Cells(x, end種別)).Value w = vbTab & Join(WorksheetFunction.Index(w, 1, 0), vbTab) & vbTab v(k, 4) = w Next 'マッチング開始 For k = 1 To UBound(v, 1) If v(k, 1) <> myCom Then myRE.Pattern = pat産地 Set ex産地 = myRE.Execute(v(k, 3)) myRE.Pattern = pat種別 Set ex種別 = myRE.Execute(v(k, 4)) If ex産地.Count > 0 And ex種別.Count > 0 Then cnt = cnt + 1 outV(cnt, 1) = v(k, 1) outV(cnt, 2) = v(k, 2) j = 2 For Each exWk In ex産地 j = j + 1 outV(cnt, j) = Mid(exWk.Value, 2, Len(exWk.Value) - 2) Next For Each exWk In ex種別 j = j + 1 outV(cnt, j) = Mid(exWk.Value, 2, Len(exWk.Value) - 2) Next End If End If Next End With If cnt = 0 Then MsgBox "抽出ゼロ件でした" Else '抽出結果の表示と並び替え Application.ScreenUpdating = False With Sheets(shnE).Range(outCell).Resize(cnt, UBound(outV, 2)) .Value = outV .Sort Key1:=Range("B7"), Order1:=xlAscending, Key2:=Range("A7"), _ Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom, SortMethod:=xlPinYin End With Application.ScreenUpdating = True MsgBox "抽出が終わりました" End If Set myRE = Nothing Set ex産地 = Nothing Set ex種別 = Nothing End Sub Sub 検索結果クリア() Dim myCom As String With Sheets(shnE) myCom = .Range(inpCell).Value .Cells.ClearContents .Range(inpCell).Value = myCom End With End Sub Private Function getLine(myCom As String) As Long Dim z As Variant With Sheets(shnL) If Len(myCom) = 0 Then MsgBox "品番が入力されていません" Else z = Application.Match(myCom, .Columns(pos品番), 0) If IsNumeric(z) Then getLine = z Else MsgBox "品番が見あたりません" End If End If End With End Function Private Function getPtn(myRow As Long, posData As String, posEnd As String) As String Dim w As Variant Dim s As String Dim c As Range Dim sep As String sep = "" With Sheets(shnL) For Each c In .Range(.Cells(myRow, posData), .Cells(myRow, posEnd)) If Len(c.Value) > 0 Then s = s & sep & c.Value sep = vbTab & "|" & vbTab End If Next If Len(s) > 0 Then getPtn = "(" & vbTab & s & vbTab & ")" End If End With End Function Private Function 前詰め(myA As Range) As Variant Dim n As Long, k As Long Dim c As Range Dim v() As String ReDim v(1 To 1, 1 To myA.Count) n = WorksheetFunction.CountA(myA) If n > 0 Then For Each c In myA If c.Value <> "" Then k = k + 1 v(1, k) = c.Value End If Next End If 前詰め = v End Function ぶらっと立ち寄り ---- ぶらっと立ち寄りさま ご連絡遅くなって申し訳ございません。 昨日まる一日研修でPCさわれませんでした ちゃんとできました! 違うのがでていたのも、気のせいだったようです。 知りたい情報が、まとまってみれて今まで目で追ってたのがバカらしく感じます。 ぶらっとさん、seiyaさん本当にありがとうございました☆... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201107/20110716195114.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97012 documents and 608132 words.
訪問者：