[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複雑な検索』（ちーず）
いつもお世話になっております。
エクセルでここまでの検索が可能がどうか、
みなさまのお力をお借りしたくお願いいたします。
下記のようなデータから、他人が品番を入力しそれに対して
産地と種類を返したいのです。
(Excel2003)
A B C D E F G 1 品番 産地１ 産地２ 産地３ 種類１ 種類２ 種類３ 2 キャベツ 北海道 青森 愛知 A10 B5 C8 3 たまねぎ 埼玉 茨城 青森 C12 B6 B3 4 レタス 山梨 北海道 高知 K3 C8 D12 5 にんじん 秋田 兵庫 鹿児島 L5 G9 B9
●最初の検索 品番から産地と種類を検索 例＞キャベツと検索ボタンを押したら、A2～G２まで結果を表示したい。
●次の検索 上記の検索結果から次の候補みたいなボタンを押すと 最初の品番と同じ、産地と種類が一致するものを表示したい
例＞キャベツと同じ産地と種類を持つ品番はレタス（北海道とC８が合致） レタス、北海道、C8という検索結果を表示させたい。
※データを変えられたくないので、
検索フォームは隣のワークシートでやろうと思っています。
VBAになりますでしょうか。。
よい方法があればご教授ください
宜しくお願いいたします
とりあえず最初の検索は、ＶＢＡじゃなくても、たとえばリストがSheet1にあったとして 検索シートのA1にキャベツ等をいれるとすれば、 B1 : =IF(ISERROR(VLOOKUP($A1,Sheet1!$A2:$G5,COLUMN(),0)),"",VLOOKUP($A1,Sheet1!$A2:$G5,COLUMN(),0)) で、これをG1までひっぱる。 次の検索は、関数素人の私には、関数で仕上げるのは無理なので、時間がとれればＶＢＡで書いてみる。 その前に、関数エキスパートさん達から回答があると思うけど。
ぶらっと立ち寄り
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を入れてみましたが”品番がありません”とでてしまいました。
私がどこか絶対間違えてると思うのですが…（－－；）
また、上記表では簡単に書いているのですが
実は、種類と産地で各３０行以上データがあり、今後も増える予定です。
種類と産地でSheetをわけています。
最初の検索も、かなり横に長い検索結果になるので
他にいい方法があればお願いします。
よろしくおねがいします（ｖｖ）
次の検索 は、実行時にA1にキャベツなんかが入っているというコードだけど、それは大丈夫？ 一応、こちらでは動いているのでシートレイアウトで正しく理解していないところがあるのかな？ 種類と産地でシートをわけているっていうのが気になるけど？ でも、関数は動いたんだよね？
第二がＶＢＡなので第一の検索もＶＢＡで統一・・というか、一つのマクロで両方カバーしたほうが 操作の上からも自然なので、統合版のコードをかいてみるけど、その前に、アップしたコードが、ちゃんと 動かなきゃね。
追記）全てのシートのシートレイアウトをもう一度説明してくれる？
ここの列は増減するとか、ここの行は増減するということは、もちろんOK。
ぶらっと立ち寄り
「最初の検索も、かなり横に長い検索結果になるので」「種類と産地でSheetをわけています」 ということで、上で聞いているシートレイアウトの再説明をしてもらってからのほうがいいとはおもうけど とりあえず、現在アップされているレイアウトのままで。 検索シートの A1 に品番を入力すると B1～G1に最初の検索結果を、またA3以降の行に次の検索結果を表示。 なお、コードは、標準モジュールではなく検索シートのシートモジュールに貼り付け。 （検索シートのシートタブを右クリックしてコードの表示を選ぶ） それと、コードとは関係がないけど、品番をいれるセル（コードではＡ１）には入力規則を設定しておいた方が便利かも。
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"という名前でとりあえず一緒にしてやってみました！
Ａ1に品番をいれると、一瞬で"品番がありません"と
メッセージがでてしまいます（ＴＴ）
今のシートの状態ですが
シート名＜Sheet1＞
Ｂ5～ＣＢ90・・・品番、
Ｃ5～Ｃ90・・・単価、
Ｄ5～ＢＡ90・・・産地、
ＢＢ5～ＣＰ90・・種類、
シート名＜検索＞
VBAが入っています。
ここのエクセルシートは、まっさらの状態です。
本当は検索ボタンなどつけたいのですが・・・
できないのに、いろいろもーしわけございません。
どうぞよろしくおねがいします。
シート名＜Sheet1＞Ｂ5～Ｂ90・・・品番
検索というシートに入っているのは
教えていただいた部分にセルのところを直しました。
ご指摘おねがいたします。
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＞Ｂ5～ＣＢ90・・・品番、 Ｃ5～Ｃ90・・・単価、 Ｄ5～ＢＡ90・・・産地、 ＢＢ5～ＣＰ90・・種類、
ひゃ～！！ 最初にアップされたレイアウトでは１行目がタイトル行で、Ａ列が品番で、Ｂ～Ｄ列が産地で、Ｅ～Ｇ列が種類じゃなかった？
直前で、どなたかがコードをアップしてくれているけど、これは、チーズさんがアップ？
追記）いずれにしても、レイアウトが大幅に変わっているので、コードもかなり手を入れなきゃいけない。
なるべく、時間をとってアップしたいけど、もしかしたら明日になるかも。
さらに追記） >産地と種類"sheet1"という名前でとりあえず一緒にしてやってみました とりあえずということは、本来は別のシートなんだろうから、二度手間になるのを避けるため 本来のそれぞれのシート名と、そのレイアウトを教えて。
ぶらっと立ち寄り
あのー、 Sheet1のA列はどうなっているのでしょう？ 削除できるのなら、削除してもらった方がコードが書きやすいのですが？ (seiya) それと、同シートの 1-4 行は何かあるのでしょうか？
Ａ列は何も入っていなので削除できます。
1～4行もタイトル、項目名が入っているだけなので削除できます。
これら削除しちゃった方がいいでしょうか？
それでは、別シート(仮にSheetA)に全てをコピーして作業しましょう。 A列は削除 1-4行の間で空白行はありませんか？ (seiya)
2、3行目が空白行になっています。
4行目に項目が入っています。
メンテする人が使わないシートなので、
項目だけ残して消した方がいいですか？
>メンテする人が使わないシートなので、 項目だけ残して消した方がいいですか？
そのようにして下さい。 原則としてリスト内には、空白行・列は存在させないようにしてください。
1行目がタイトル行で2行目以下がデータということで書き始めますが、 もう一度、変更後の項目列を教えてください。 (seiya)
変更後ですが・・・
＜行＞
1行目が項目、2行目からがデータ（実際には86行ありました）
＜列＞
Ａ列が品番、Ｂ列が単価、Ｃ列～ＡＺ列まで産地、ＢＡ列～ＣＯ列までが種類
いま確認したところ
品番、単価は入っていますが、産地種類が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 という違う結果がでてきました(ＴＴ）
何回かコマンド２のボタンを押してみましたが
一致する品番がでてきませんでした。
ここまですごいのができたので、何とか完成を見てみたいのですが・・・
追加のお願いで申し訳ないのですが
品番や単価、種類など項目をのせることはできますか？
種類、産地のデータが似た数字と英字の組み合わせなので
見分けができればなと思いました。
終わったあとのクリアボタンなどもあると助かります（ｖｖ；）
いろいろわがまま言ってすみません・・・
> Ｂ列の単価が安い順にだすこともできますでしょうか（＞＜）？ これはSheetAをB列で昇順に並べ替えしておけば、よいでしょう。
あとは、何分こちらでは検証できませんので、実際にファイルを見ること が出来ないと難しいですね。 (seiya)
ファイルをお見せしてもいいのですが、
どのような方法でファイルをのせられますか？
CommandButton2 のコードを少々変更しましたので、試してください。 (seiya)
あと検索結果が空白セルを含めてＣＯ列まで罫線と一緒に
でてしまうのはしょうがないことでしょうか？
検索結果が10個ぐらいなのに、
だいぶ横にスクロールしないと結果が見れないので残念なのですが（；；）
一か所タイプミスがありました。 まず、データが正確に抽出できるかどうかを確認しましょう。 (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さんに登場いただき、コードも大詰めになってきたようだね。 ここで、また違ったコードを提案すると、ちーずさんも混乱しそうなので、しばらくはＲＯＭでいきます。 テーマとしてはおもしろそうなので、seiyaさんとは違った構成のコードを書いてみるつもりだけど。 列が大幅に増えたので、照合型0のMatchでは、荷が重すぎるね。さて、何を使うか。
ぶらっと立ち寄り
いろいろありがとうございます（＾＾）
早速自宅へ帰ったので、やってみようと思ったのですが
自宅ＰＣはexcel2007なのでマクロが無効というメッセージが
でて使用できません（ＴＴ）
オプションで無効を有効にしてるんですが・・・
早くやりたくてウズウズです。
xlsm で保存しましたか？ (seiya)
エクセルのアイコンもビックリマークのようなものがついているのですが
オプションのところも"すべてのマクロを有効にする"に
チェックが入っているので、何がダメなのかわかりません。
もうかれこれ1時間ほど格闘してます笑
2007でＶＢＡをやるのは初めてで、もたついてすみません。。泣）
明日会社でまたやります（＾＾）
早速やってみました！
今の時点で気がついたところです。
①コマンドボタン２ですが、同じ品番があるのに
"データはありません"となります。
②コマンドボタン３の消去ですが、全部行をクリアにしたいのですが
品番しか消えません。。
③項目列なのですが、産地、種類のところは項目ではなく
下記のようにそれぞれの名前が項目になっています。
それなので、どれが産地で種類かはこのデータでは見分けがつかない状態です。
④結果がＣＯ列まで表示されてしまいます。
<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以降の４行目に産地まで、C5以降の５行目に種別を。 また次の検索結果は７行目以降に表示。 なお、コートとしては、産地、種別、それぞれ、間に空白セルがあっても対応しているが これが全て左詰ということであれば、もう少し実行時間は短縮できる。 また、たとえば キャベツ が 北海道、栃木 で AA、BB だったとして セロリも 北海道、栃木 で AA、BB だった場合、次の検索結果として セロリ 北海道 AA セロリ 北海道 BB セロリ 栃木 AA セロリ 栃木 BB と４つ抽出している。もし、最初に見つかったもののみ代表で セロリ 北海道 AA と１つのみ抽出でよければ、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
ぶらっと立ち寄り
↑ いままでのやりとりをよく読むと最終的には、リストはタイトルが１行目でデータが２行目だね。
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
ぶらっと立ち寄り
やってみました！
代表の方が、スッキリしてて見やすいですね！
ただそれをもとに倉庫へ在庫を見にいくので、
代表ものがなかった場合、次の候補の検索をしなくてはなりません。。
たまに、産地が違うのに種別が一致してるものも拾ってきます。
最初の検索ですが、
ここも空白を削除してつめることは可能でしょうか？
検索後、画面に何もでてないときがあり
一瞬、産地も種別もがないのかな。と思うと
ずっと右の列にスクロールするとあったりします（＾＾）
でもここまでできれば、もう完成に近い感じがします♪
>最初の検索ですが、ここも空白を削除してつめることは可能でしょうか？
うん、できるよ。
>代表ものがなかった場合、次の候補の検索をしなくてはなりません。。
たとえば抽出された品番の行の最初のほうに、検索元とおなじ産地を左詰で、その後に検索元と同じ種別を左詰で。 こんなことはできると思うけど。
それより、【たまに、産地が違うのに種別が一致してるものも拾ってきます。】 もし、こうなったとしたらバグだけど、そうなるの？
ぶらっと立ち寄り
一応簡単なテストはしてあるけど試してみて。 ・最初の検索、産地、種別を前詰めに。 ・次の検索、品番ごとに１行だけど、検索元と同じ産地、種別を一行に列挙。これも前詰め。 コード、フルセットアップするので、全てリバイスしてね。
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
ぶらっと立ち寄り
ご連絡遅くなって申し訳ございません。
昨日まる一日研修でＰＣさわれませんでした
ちゃんとできました！
違うのがでていたのも、気のせいだったようです。
知りたい情報が、まとまってみれて今まで目で追ってたのがバカらしく感じます。
ぶらっとさん、seiyaさん本当にありがとうございました☆
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.