[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『サジェストからのデータ抽出』(まこさん)
http://www.excel.studio-kazu.jp/kw/20150517160757.html
を参考にサジェスト機能は利用できる様になったのですが、
一致したデータから他のデータも取り出したいのですが良い方法を教えて下さい。
見積書の管理を行います。
見積りした物は随時データベースに追加されます。
図番をキーとしてサジェスト機能を使いながら、過去の実績を検索したいです。
一致した物があれば、品名・単価等過去のデータを、抽出したです。
その際、過去に複数見積りをしている場合があるので、単価・個数・見積日を
確認してから、今回使うデータを選びたいです。
データベース(例)
連番 図番 品名 単価 個数 見積日
1 AB0011 カバー 1000 2 2015/2/2
2 CC0012 フレーム 2500 4 2015/3/10
3 JD0013 BK 500 3 2015/6/15
4 AB0011 カバー 1100 1 2014/10/1
5 GB0015 シャフト 3000 3 2015/8/8
6 KA0016 パン 1000 2 2015/9/7
入力シート
図番 品名 単価 個数
< 使用 Excel:Excel2013、使用 OS:Windows7 >
ご自分で出来る程度のものにまずはトライすることも大事なことではないですか?
機能修正や機能追加のつど、他人にお願いするのはどうなんでしょう。
少なくとも、ご自分でどこまでトライして、どこで詰まっている、
この箇所を教えて欲しい、という質問にされたらどうですか?
(γ) 2016/02/02(火) 21:30
γさんの、フィルターオプション案に大賛成です。 参照トピにあるようなサジェスト機能を実現する煩雑な(かつ、わかりにくい)コードも不要ですし 手作業でやっても簡単ですから、コード化しても、ご自分で何をやっているのかがわかり、メンテナンス時も楽です。
ちょっと手作業でやってみましょう。 どんなものか体感できると思いますので。 操作をマクロ記録すると、基本になるコードが生成されますから、それをブラッシュアップすれば必要コードの心臓部分の部品として 十分に使用に耐えるコードが生成されます。
あとは、このコードを、入力シートのA列の図番セルを右クリックしたら自動的に動くとか、あるいはダブルクリックしたら自動的に動くとか さらには(遊びですけど)、図番セルの上にマウスを持ってくると自動的に動くとか、応用していけばいいと思います。
まず、体験版として操作です。
●準備 ここはマクロ記録しません。
入力シートの G1〜K1に 図番 品名 単価 個数 見積日 と、タイトル項目を入力しておきます。 また、G2 に、任意の図番を入れておいてください。
●操作
1.入力シートを表示します 2.データタブフィルターグループの詳細設定をクリック 3.リスト範囲(L) に データベースシートのA1から始まる領域を指定。(データベース!A1:F●) 4.検索条件範囲(C)に 入力シートの G1:G2 を指定。 5.指定した範囲(O) を選び、抽出範囲(T) に 入力シートの H1:K1 を指定。 6.OKボタン
これで、入力シートの H〜K列に、データシート内の同じ図番を持ったデータが表示されます。 (もし、G2 に A とだけいれてあれば A から始まるすべてのデータ、C12 といれれてあれば C12 から始まるすべての図番が表示されます)
(β) 2016/02/03(水) 06:31
自分なりにネット上の情報を参考にコードを作ってみましたが、リストボックスから入力に代入する方法が
上手くいきません。
今まで問題がなかったところに影響が出てしまいます。
あと、なぜか検索した結果が何回か繰り返して入力控えにコピーされてしまいます。
コードに問題があるのは間違いないのですが、問題の箇所をご指摘頂けませんか?
入力シートには適当な場所にactivexのリストボックスとリストボックスに入力する為の入力控えがG〜J列にあります。
リストと控えには「図番」「品名」「単価」「見積日」が入ります。
入力フォームとしてA〜Dに「図番」「品名」「単価」「個数」があり、A2〜A5に文字を入力すれば、
リストボックスに表示されるまではなんとか出来ました。
希望としてはリストボックスのデータをクリックすると、「図番」「品名」「単価」を入力したいと思っています。
入力(シート)
Private Sub ListBox1_Click()
End Sub
If Target.Column = 1 Then If Target.Row >= 2 And Target.Row <= 5 Then Call 抽出 End If End If
ListBox1.List = Range("g2", Range("J" & Rows.Count).End(xlUp)).Value
End Sub
モジュール
Sub 抽出()
'入力控えに抽出した物もコピーするマクロ
Dim shN As Worksheet Dim shH As Worksheet
Set shN = Sheets("入力") Set shH = Sheets("品名リスト")
Dim aa, ac, ar, myRow1
aa = ActiveCell.Address 'セル番地
ac = ActiveCell.Column 'セルの列番号
ar = ActiveCell.Row 'セルの行番号
If Range("A" & ar) <> "" Then
shN.Range("G2:J50").Clear '入力控えをクリアー
shH.Range("A1").AutoFilter Field:=2, Criteria1:=Range("A" & ar) & "*" 'オートフィルタによる抽出
myRow1 = shH.Range("A" & Rows.Count).End(xlUp).Row
shH.Range("B2:D" & myRow1).Copy shN.Range("G2:I" & myRow1) '入力控えに抽出結果をコピペ shH.Range("F2:F" & myRow1).Copy shN.Range("J2:J" & myRow1) '入力控えに抽出結果をコピペ
Else shN.Range("G2:J50").Clear '空欄時入力控えをクリア End If
shH.Range("A1").AutoFilter 'オートフィルタ解除
If ac > 1 Then ActiveCell.Offset(0, -1).Activate 'アクティブセルを左に1つ戻す End If
End Sub
色々試しながら複数の見本コードを混ぜているので、不要な物も沢山あります。
お手数ですがヒントでも、頂けると助かります。
(まこさん) 2016/02/04(木) 19:05
今回、↑ でアップされたコードにはまだ目を通していませんが、
入力シート 図番 品名 単価 個数
とあったので、シート上で 図番を選択するんだと思っていたんですが、リストボックスで選択なんですか? リストボックスでハンドリングしたいということなら、アップされたコードを元に皆さんから回答もあるかと思いますが 直接 A列から選ぶ案をいくつか。(いずれもフィルターオプションを利用しています) いずれも 入力シートの G1〜K1に 図番 品名 単価 個数 見積日 という項目名がセットされていること かつ、"Sheet2" (データベース)に、そちらの説明通りのレイアウトのデータがあるという前提です。 (データベースシートも1行目がタイトル行)
●図番を選び、コマンドボタンをクリックして実行する案。 ActiveXのCommandButton1 を配置。シートモジュールに。
Private Sub CommandButton1_Click()
Range("G2").Value = ActiveCell.Value Sheets("Sheet2").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range("G1:G2"), CopyToRange:=Range("H1:K1"), Unique:=False
End Sub
●図番セルをダブルクリックして実行する案。シートモジュールに。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, Columns("A")) Is Nothing Then Exit Sub Cancel = True Range("G2").Value = Target.Value Sheets("Sheet2").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range("G1:G2"), CopyToRange:=Range("H1:K1"), Unique:=False End Sub
●遊びで。図番セルの上にマウスをあてれば抽出して表示。マウスを動かして別の図番にあてれば、表示切替。 ThisWorkbookモジュールに。
Option Explicit
Private Declare Function GetCursorPos Lib "User32" (lpPoint As ptsXY) As Long
Const MYSHEET As String = "Sheet1" '★入力シート名
Const DATABASE As String = "Sheet2" '★データベースシート名
Dim DoLoop As Boolean
Dim lastTxt As String
Private Type ptsXY
x As Long y As Long End Type
Private Sub Workbook_Open()
Start End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Start End Sub
Private Sub Start()
Select Case ActiveSheet.Name Case MYSHEET Application.OnTime Now(), "Thisworkbook.監視開始" End Select End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
If Sh.Name = MYSHEET Then 監視終了 End Sub
Sub 監視開始()
Dim MPt As ptsXY Dim x As Long Dim vv As Object
DoLoop = True lastTxt = "" Do While DoLoop GetCursorPos MPt Set vv = ActiveWindow.RangeFromPoint(MPt.x, MPt.y) If TypeName(vv) = "Range" Then If Not Intersect(vv, Columns("A")) Is Nothing Then If vv.Value <> "" Then If vv.Value <> lastTxt Then Range("G2").Value = vv.Value Sheets(DATABASE).Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range("G1:G2"), CopyToRange:=Range("H1:K1"), Unique:=False lastTxt = vv.Value End If End If End If End If
DoEvents
Loop
End Sub
Sub 監視終了()
DoLoop = False End Sub
(β) 2016/02/04(木) 19:24
まだ、コードは詳細には読んでいませんが 図番セルは A2:A5 だったんですね。 ↑でアップしたコードはA列すべてが図番だと思っているコードで巣が、A2:A5に絞るというのはたやすくできます。
で、あいかわらず、リストボックスを無視した セルの Changeイベントで処理する案です。
提案です。これら、いずれかの方法で G列以降に抽出したもののなかでダブルクリックして、A列側に コピーするという運用はいかがでしょうか? (G列以降がリストボックスがわりという感じです)
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A2:A5")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Range("G2").Value = Target(1).Value Sheets("Sheet2").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range("G1:G2"), CopyToRange:=Range("H1:K1"), Unique:=False
Application.EnableEvents = True
End Sub
(β) 2016/02/04(木) 19:56
私がアップしたコードを試す際には、現行のシートのChangeイベントコードは消してくださいね。
ついでに、
>>aa = ActiveCell.Address 'セル番地 >>ac = ActiveCell.Column 'セルの列番号 >>ar = ActiveCell.Row 'セルの行番号
セルの内容が変更されれば、変更されたセル情報が Target に入って、とんでくるんですが、 この時の ActiveCell は 変更されたセルではありません。 たとえば、A1 に何か入れてエンターすると発生しますが、その時、標準設定なら、下の A2 がアクティブになりますね。 これ、具合悪いですよ。
(β) 2016/02/04(木) 20:57
回答ありがとうございます。
自分の想定として、A列の図番は途中入力でリストに出して、リストから選んで戻すをしたかったんです。
教えて頂いたコードを参考に力技で上記を実行してみました。
図番は途中一致するものがある為、検索キーをF列に移動しました。
G列をダブルクリックすると、図番・品名・単価を返してくれます。
美しくはないですが・・
Public y As Integer
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A2:A5")) Is Nothing Then Exit Sub
Application.EnableEvents = False
y = Target.Row
Range("F2").Value = Target(1).Value Sheets("Sheet2").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range("F1:F2"), CopyToRange:=Range("G1:K1"), Unique:=False
Application.EnableEvents = True
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim ty As Integer
If Intersect(Target, Columns("G")) Is Nothing Then Exit Sub Cancel = True
ty = Target.Row
Range("A" & y).Value = Target.Value Range("B" & y).Value = Range("H" & ty) Range("C" & y).Value = Range("I" & ty)
End Sub (まこさん) 2016/02/05(金) 10:46
>>美しくはないですが・・
お望みなら、リストボックス対応をしますけど、
>>A列の図番は途中入力でリストに出して
この 途中入力で というところのイメージを明確にしていただけませんか? どこに、どのような入力をしたタイミングで、リストボックスにどのような表示をしたいのかというあたりを。
それと、アップされた構えでは、ダブルクリックして A列に書き戻す際に、イベントの連鎖が発生して Changeイベントに飛び込む。 で 対象領域(A2:A5)なので フィルタリングが実行される。 このような無駄な動きが裏で発生していますよ。
(β) 2016/02/05(金) 11:40
途中入力のイメージは、見積書作成時に以前に見積りした実績を検索したいと思っています。
その際、全部の図番を打ち込まなくても検索出来て、検索した結果から選んで入力途中のセルに
図番・品名・単価を入力したいと思っています。
対象領域(A2:A5)は検索を入力するセルでもあり、見積書の図番入力セルでもあるのです。
実際、過去に実績が無ければそのまま全文字を打ち込みます。
イベントの連鎖は気がつきましたが、とりあえずは代案が思いつかなかったのでそのままにしました。
どちらかというと、対象領域(A2:A5)に入力途中でエンターを押すと右に移動すると、リストが多すぎた
場合に再度戻って最初から打ち直しになるのと、空白にした時リストが全部表示されるのを対策したいのと
思っています。
今は下記のコードを追加して空白時の対応にしました。
If Target(1).Value = "" Then Range("F2").Value = "xxxxxx" Else Range("F2").Value = Target(1).Value End If
自分の実力ではこれ位が精一杯です
(まこさん) 2016/02/05(金) 13:09
提案も含め、もしかして以下のようなことをやりたかったのでしょうか?
●準備
・入力シートの使用領域から少なくとも1つあけた右の方、たとえば X1 に 図番といれます。 ・X列から、さらび 1列あけて Z1 にも 図番、AA1に品名、AB1 に単価、AC1 に個数、AD1 に見積日 といれます
これらは作業域です。もっと右側でも構いません。
・ActiveX の TextBox を配置します。(下記コードでは TextBox1 としています) A2:A5の範囲を選択すると、このTextBoxが選択セルのところにきます。 プロパティで Visible を False にしておきます。
・ActiveX の ListBox を配置します。(下記コードでは ListBox1 としています) プロパティで ColumnCount を 5、Visible を False にしておきます。
以下コードです。シートモジュールに。 A2:A5 内のセルを選択すると その場所にTextBoxが、またListBoxも所定の場所に表示され、 TextBoxのタイプに合わせて、ListBoxに該当のリストが表示されます。 ABC と入力したとすると、最初は Aから始まるデータ、次に ABから始まるデータ、さらに ABCから始まるデータと 表示がタイプに合わせて絞り込まれていきます。
で、ListBoxのなかからデータを選び ダブルクリックすると、選んだ行のA〜D列に書き込まれ、TextBox,ListBoxが非表示になります。
Private Sub TextBox1_Change() ListBox1.Clear Range("X2").Value = TextBox1.Value Sheets("Sheet2").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range("X1:X2"), CopyToRange:=Range("Z1:AD1"), Unique:=False With Range("Z1").CurrentRegion If .Rows.Count > 1 Then ListBox1.List = .Offset(1).Resize(.Rows.Count - 1).Value End With End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target(1), Range("A2:A5")) Is Nothing Then TextBox1.Visible = False ListBox1.Visible = False Exit Sub End If
With TextBox1 .Visible = True .Left = Target(1).Left .Top = Target(1).Top .Text = Target(1).Value End With
ListBox1.Visible = True
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim x As Long Dim r As Range
Set r = TextBox1.TopLeftCell.EntireRow With ListBox1 x = .ListIndex r.Range("A1").Value = .List(x, 0) r.Range("B1").Value = .List(x, 1) r.Range("C1").Value = .List(x, 2) r.Range("D1").Value = .List(x, 3) End With
TextBox1.Visible = False ListBox1.Visible = False
End Sub
(β) 2016/02/05(金) 14:29
(まこさん) 2016/02/06(土) 10:23
>>フィルタオプションって数字のみの検索は出来ないのですか?
たとえば 数値データで 123456 や 12345 があって、 1 といれると 123456 も 12345 も 抽出するということですか? そうですねぇ。フィルターオプションで、指定数字を含む といった抽出は、そのままではできないようです。 やるなら、ちょっと工夫が必要ですが、数字だけの図番があるということですか?
>>あと、シートの保護中にもデータの受け渡しに影響が出てしまいました
シートが保護されているなら、コード内で作業域セルに書きこんでいますので、それはエラーになるでしょうね。 作業域のみならず、リストボックスからの選択結果をシートに書きこむわけですが、保護されていれば、それもできませんよね? やるなら、関連コードの中で保護を解除し処理して再保護という手立てが必要になります。 (UserInterfaceOnly付の保護でやれればいいのですが、フィルター関連でオールマイティではないので)
シートは保護必要なんですね?
(β) 2016/02/08(月) 20:15
とりあえず、図番が数字だけのものがあって、その場合は 1 と指定すると 1から始まる数字を抽出するという要件であれば、
TextBox1_Change を以下で置き換えて試してください。
Private Sub TextBox1_Change() Dim sv As String ListBox1.Clear sv = Range("X1").Value If IsNumeric(TextBox1.Value) Then Range("X1").ClearContents Range("X2").Formula = "=LEFT(SHeet2!B2," & Len(TextBox1.Value) & ")=""" & TextBox1.Value & """" Else Range("X2").Value = TextBox1.Value End If Sheets("Sheet2").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range("X1:X2"), CopyToRange:=Range("Z1:AD1"), Unique:=False With Range("Z1").CurrentRegion If .Rows.Count > 1 Then ListBox1.List = .Offset(1).Resize(.Rows.Count - 1).Value End With Range("X1").Value = sv End Sub
(β) 2016/02/08(月) 23:09
加えて、シート保護対応を組み込んだものを。
SelectionChangeは変更していませんが、フルセット。 なお、標準モジュール追加です。
●シートモジュール
Private Sub TextBox1_Change() Dim sv As String
Me.Unprotect
ListBox1.Clear sv = Range("X1").Value
If IsNumeric(TextBox1.Value) Then Range("X1").ClearContents Range("X2").Formula = "=LEFT(SHeet2!B2," & Len(TextBox1.Value) & ")=""" & TextBox1.Value & """" Else Range("X2").Value = TextBox1.Value End If
Sheets("Sheet2").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range("X1:X2"), CopyToRange:=Range("Z1:AD1"), Unique:=False
With Range("Z1").CurrentRegion If .Rows.Count > 1 Then ListBox1.List = .Offset(1).Resize(.Rows.Count - 1).Value End With
Range("X1").Value = sv
protectAgain Me
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target(1), Range("A2:A5")) Is Nothing Then TextBox1.Visible = False ListBox1.Visible = False Exit Sub End If
With TextBox1 .Visible = True .Left = Target(1).Left .Top = Target(1).Top .Text = Target(1).Value End With
ListBox1.Visible = True
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim x As Long Dim r As Range
Me.Unprotect
Set r = TextBox1.TopLeftCell.EntireRow With ListBox1 x = .ListIndex r.Range("A1").Value = .List(x, 0) r.Range("B1").Value = .List(x, 1) r.Range("C1").Value = .List(x, 2) r.Range("D1").Value = .List(x, 3) End With
TextBox1.Visible = False ListBox1.Visible = False
protectAgain Me
End Sub
●標準モジュール
Sub protectAgain(sh As Worksheet) '現在の保護要素を継承したシート保護 Dim pp As Protection
With sh '対象シート
Set pp = .Protection
.Protect DrawingObjects:=.ProtectDrawingObjects, _ Contents:=True, _ Scenarios:=.ProtectScenarios, _ AllowFormattingCells:=pp.AllowFormattingCells, _ AllowFormattingColumns:=pp.AllowFormattingColumns, _ AllowFormattingRows:=pp.AllowFormattingRows, _ AllowInsertingColumns:=pp.AllowInsertingColumns, _ AllowInsertingRows:=pp.AllowInsertingRows, _ AllowInsertingHyperlinks:=pp.AllowInsertingHyperlinks, _ AllowDeletingColumns:=pp.AllowDeletingColumns, _ AllowDeletingRows:=pp.AllowDeletingRows, _ AllowSorting:=pp.AllowSorting, _ AllowFiltering:=pp.AllowFiltering, _ AllowUsingPivotTables:=pp.AllowUsingPivotTables
End With
End Sub
(β) 2016/02/09(火) 08:58
たとえば 数値データで 123456 や 12345 があって、 1 といれると 123456 も 12345 も 抽出するということですか?
そういうことですが、1文字だけでなく、候補が多ければ増やしていくので、
この方法だと難しいかもしれません。
オートフィルタであれば「数字+*」で可能なので、以前考えたコードを参考にしてみたいと思います。
(まこさん) 2016/02/09(火) 11:35
>>そういうことですが、1文字だけでなく、候補が多ければ増やしていくので、 この方法だと難しいかもしれません。
なぜ難しいのかわかりませんが、1 といれれば 1からはじまるものを抽出、つづけて 12 にすれば 12で始まるものを抽出 といったように 絞り込んでいるのがアップしたコードです。
試してみて具合が悪かったということですか?
(β) 2016/02/09(火) 16:18
問題を調べるのに時間が掛かり申し訳ありませんでした。
台帳の構成が当初と変わっていた為、上手く機能していませんでしたが、
"=LEFT(SHeet2!B2," & Len(TextBox1.Value) & ")=""" & TextBox1.Value & """"
の意味を調べて対応したところ、上手く機能しました。
ありがとうございました。
(まこさん) 2016/02/11(木) 09:59
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.