[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『略語辞書の作成』（橋の下から）
A列にローマ字で略語(二文字から五文字)に対して、その意味をB列に書き込んでます。
検索は、そのままスクロールさせてましたが、段々と多くなり、フィルターを使用してA列の初めの一文字か二文字を入力して「で始まる」検索する様になりました。
C1のシートが空いてますので、そこに検索の文字を書き込み、ボタンひとつ程度での検索マクロの登録や他の方法で、書き込んだ文字から、A列の略語を検索する方法を教えて下さい。
例えばC1に「A」と書き込むとB列のAで始まる事のみ、多ければC1に再度「AF」とかの次の文字を足して入力してとしたいと思います。
コンソールボックスに検索文字を書き込み、検索ボタンでも良いのですが、出来るだけ簡単にしたい(検索側が１番ですが、作る側も・・)と思ってます。
エクセルの基本機能で[編集(E)]メニュー→[検索(F)]もあります。
また[データ(D)]メニュー→[フォーム(O)]で表示されたフォームで [検索条件(C)]ボタンを押して略号を入力して[次を検索(N)]ボタンを押す。
あえてマクロにする必要はなさそうに思います。 （kazu）
ほんならこんなんどうでっか？
1)Alt+F11でVBEを開く
2)プロジェクト欄のSheet1をWクリック
3)下のコードをコピペ
4)念のため「挿入」→「標準モジュール」を選択してそこにtestをコピペ
これは何かでエラーが出た時実行してくらはい。
エクセルに戻りC1に検索したいデータを入力してみておくんなはれ。 どうでっか？ばっちりでっしゃろ・・・（笑
これは余談
>あえてマクロにする必要はなさそうに思います。
私の遊びを奪い取らんとってえな・・・（笑
ほな（弥太郎）
’Sheetモジュールへ
'----------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, n As Long
Dim data_len As Integer
Dim data
If Target.Address <> "$C$1" Then Exit Sub
Application.EnableEvents = False
data = Target
Range("c:d").Clear
If data <> "" Then
Range("c1") = data
n = 2
For i = 1 To Range("a65536").End(xlUp).Row
data_len = Len(data)
If Left(Cells(i, 1), data_len) = data Then
Cells(i, 1).Resize(, 2).Copy Destination:=Cells(n, 3)
n = n + 1
End If
Next i
End If
Application.EnableEvents = True
End Sub
'標準モジュールへ
'----------------------------
Sub test()
Application.EnableEvents = True
End Sub
すみません全然関係ないですが、試してみたら、魔法のようでした。
尊敬する、弥太郎さんのコードを借りいたしまして、、、 こんなのどうせっしゃろ（笑
’Sheetモジュールへ
'----------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, n As Long, l As Long
Dim data_len As Integer
Dim data
If Target.Address <> "$C$1" Then GoTo hukumu
Application.EnableEvents = False
data = Target
Range("C:F").Clear
data_len = Len(data)
If data <> "" Then
Range("c1") = data
n = 2
For i = 1 To Range("a65536").End(xlUp).Row
If Left(Cells(i, 1), data_len) = data Then
Cells(i, 1).Resize(, 2).Copy Destination:=Cells(n, 3)
n = n + 1
End If
Next i
End If
Application.EnableEvents = True
hukumu:
If Target.Address <> "$D$1" Then Exit Sub
Application.EnableEvents = False
data = Target
Range("C:D").Clear
If data <> "" Then
Range("D1") = data
n = 2
For i = 1 To Range("a65536").End(xlUp).Row
data_len = Len(Cells(i, 1))
For l = 1 To data_len
If Mid(Cells(i, 1), l, 1) = data Then
Cells(i, 1).Resize(, 2).Copy Destination:=Cells(n, 3)
n = n + 1
l = data_len
End If
Next l
Next i
End If
Application.EnableEvents = True
End Sub
'標準モジュールへ
'----------------------------
Sub test()
Application.EnableEvents = True
End Sub
C1 → 頭の文字からの検索（文字数複数可） D1 → １文字のみ入力（含むものを検索）
（キリキ）(〃⌒o⌒)b
おっ！ ナムァイキな（笑 Like演算子なんかを使うとCells(i,1)のセルを全部Forで廻す必要がなくなる〜。 先ずはイチャモンいっぱぁつ。 イチャモン屋も結構気持ちのええもんやなぁ。（笑 ほな（弥太郎）(〃⌒o⌒)b
>Like演算子なんかを使うとCells(i,1)のセルを全部Forで廻す必要がなくなる〜。 わざわざのご指導、ありがとうございます〜♪ Φ(。。 )メモメモ
本日は仕事の為、時間のあるときにやってみます〜☆ （キリキ）(〃⌒o⌒)V
弥太郎さんへ 出されていた宿題を下記のようにしてみました〜♪
A B C D
1 一文字検索 文字先頭から検索 用語名称 意味
2 l l l
3 ↑１文字入力 ↑ uh 1
4 先頭より検索する文字入力 asd 2
5 dis 3
6 fhds 4
7 ajgfk 5
7 AsKj 6
8 gnrij 7
9 reix 8
10 ergj 9
11 hAg 10
※B1には、"*"や"?"も使用できるようです ※A1に、複数を字を入れても２文字目からは削除します ※大文字・小文字の区別はなしです
Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, n As Long
Dim data
If Target.Address = "$B$2" Then
Application.EnableEvents = False
data = Target
Range("A2:B65536").ClearContents
If data <> "" Then
Range("B2") = data
n = 3
For i = 3 To Range("C65536").End(xlUp).Row
If Cells(i, 3) Like data & "*" Then
Cells(i, 3).Resize(, 2).Copy Destination:=Cells(n, 1)
n = n + 1
End If
Next i
End If
Else
If Target.Address <> "$A$2" Then Exit Sub
Application.EnableEvents = False
data = Mid(Target, 1, 1)
Range("A2:B65536").ClearContents
If data <> "" Then
Range("A2") = data
n = 3
For i = 3 To Range("C65536").End(xlUp).Row
If Cells(i, 3) Like "*[" & data & "]*" Then
Cells(i, 3).Resize(, 2).Copy Destination:=Cells(n, 1)
n = n + 1
End If
Next i
End If
End If
Application.EnableEvents = True
End Sub
>イチャモン屋も結構気持ちのええもんやなぁ。（笑 是非、いちゃもんつけてください（＾＾）
修正（利便性を考慮し、データと出力部分を入れ替えました） （キリキ）(〃⌒o⌒)b
まあなんと、見事なでけばえ！！、１００点満点ですわ、えぇ。 特にLike演算子を即座にマスターするなんざぁ、尊敬に値しまっせ、ホンマ。 いや、おそれいりました。 ほな・・・
で終わってしもたら >是非、いちゃもんつけてください のご要望に応えん事になりますんで、無理矢理イチャモンつけときまっさぁ。（笑 Application.EnableEvents = Falseが２回使われてますけど、これなんとか一回で おさまりまへんかぁ？
n=3 も分岐毎に初期化してますけど、これもでけたら一回に・・・
それに関連した作業ですけど
For i = 3 To Range("C65536").End(xlUp).Row
If Cells(i, 3) Like data & "*" Then
Cells(i, 3).Resize(, 2).Copy Destination:=Cells(n, 1)
n = n + 1
End If
Next i
この作業も、仮に分岐が増えたばやいも分岐毎に同じ事を書かなあきまへんわなぁ。
Cells(i,3) Like 変数 にしてしもうて サブルーチンでやってしもうたら
一回の記述で済みまっしゃろ。
例えば
Select Case Target.Address(0, 0)
Case "$B$2"
find_data = data & "*"
work (find_data)
といった塩梅に変数find_dataにおさめてそれを引数にしたうえでworkという
サブルーチンに飛ばして処理するような方法もありますしなぁ。
それとRange("C65536").End(xlUp).Rowも同じ数値を得られる筈ですから
変数に収めて使用すると、煩わしさが解消されますからなぁ。
以上無理矢理イチャモンつけました〜（笑 ここも長うなったらアカンのんで弥太郎流マクロを「弥太郎の部屋」へ書いてみます わ（暇な時）。 せやけど、私より優れたんを書いたら、わかってまっしゃろなあ？ あんさんの人格欄に×印がはいります〜（笑 ほな・・・（弥太郎）(〃⌒o⌒)b
大変解かり易い、説明でありがとうございました。 ご返事が遅れて申し訳有りません。ついでと言っては失礼ですが・・ １，Ａ列の文字が半角、全角関係なく検索出来る方法が有りましたらお願いいたします。 ２，ａ列が小文字でも大文字でも検索出来る方法が有りましたらお願いいたします。 理由は、１，書き込む方が多く、半角だったり、全角だったり。 ２，一般的には小文字で使用する略語はＡ列に小文字で入力してあります。が時には大文字で使用も有り得るので、どちらでも検索出来ると便利なのですが・・ (橋の下から)
横から、失礼します〜
>１，Ａ列の文字が半角、全角関係なく検索出来る方法が有りましたらお願いいたします。 >２，ａ列が小文字でも大文字でも検索出来る方法が有りましたらお願いいたします。 ↑両方とも同じことですよね？？
大文字・小文字でヒットさせたいってことですよね？ σ(^o^;)のにも入ってますが、頭に↓を入れるとそうなりますよ（＾＾） Option Compare Text
（キリキ）(〃⌒o⌒)ｂ
有難う御座いました。 とてもスームズに検索出来る様になりました。 素人の為にここまでして頂き感謝感謝です。 (橋の下から)
ではでは、 もう少しいじってみたものを〜
大文字・小文字両方ＯＫ Sheet2のA列に、単語。B列に、意味。←各３行から Sheet1のA列の３行に、一文字検索。B列の３行に、複数検索文字。 として、、、
Option Compare Text
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, n As Long
Dim data As Variant, data_C As Variant, key As Variant
Dim Mydata(1 To 2) As String
Dim MySh1 As Worksheet, MySh2 As Worksheet
Set MySh2 = Worksheets("Sheet2")
n = 3
Select Case Target.Address
Case "$B$2"
data = Target
key = "$B$2"
data_C = data & "*"
Case "$A$2"
data = Mid(Target, 1, 1)
key = "$A$2"
data_C = "*[" & data & "]*"
Case Else: Exit Sub
End Select
Application.EnableEvents = False
Range("A2:B65536").ClearContents
If data <> "" Then
Range(key) = data
For i = 3 To MySh2.Range("A65536").End(xlUp).Row
If MySh2.Cells(i, 1) Like data_C Then
With MySh2
Mydata(1) = .Cells(i, 1)
Mydata(2) = .Cells(i, 2)
End With
Cells(n, 1) = Mydata(1)
Cells(n, 2) = Mydata(2)
n = n + 1
End If
Next i
End If
Application.EnableEvents = True
End Sub
で如何でしょう〜♪ （キリキ）(〃⌒o⌒)ｂ
キリキさんへ、Sheet1検索が２行目で行えるのですか・・ Ａ列の検索は検索文字に関係なく、只単に、Sheet２のＡ３からの順不動で全部が 表示されてしまいます。 Ｂ２では心地よい、検索が出来てます。 もし新たに書いて頂けますと、全体の書き込みから何かが勉強出来る気がして 書かせて頂きました。 今はただ、コピーして貼り付けてるでけです。 (橋の下から)
橋の下からさんへ 遅くなりました。。。 ちょっと忙しかったので、レスが遅くなってしまいました。すいませんm(_ _)m
>Sheet2のA列に、単語。B列に、意味。←各３行から >Sheet1のA列の３行に、一文字検索。B列の３行に、複数検索文字。 上記Sheet1の検索文字入力場所は、A2とB2でしたね・・・（汗
>Ａ列の検索は検索文字に関係なく、只単に、Sheet２のＡ３からの順不動で全部が 表示されてしまいます。 どんな文字を入力しました？ σ(^o^;)ので確認したのですが、きっちり出るみたいなのですが。。。
ちょっと動きが遅かったですが、、、 試しに、下記のコードでは如何でしょう？
Option Compare Text
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, n As Long
Dim data As Variant, data_C As Variant, key As Variant, Mydata As Variant
Dim MySh1 As Worksheet, MySh2 As Worksheet
Set MySh1 = Worksheets("Sheet1")
Set MySh2 = Worksheets("Sheet2")
n = 3
Select Case Target.Address
Case "$B$2"
data = Target
key = "$B$2"
data_C = data & "*"
Case "$A$2"
data = Mid(Target, 1, 1)
key = "$A$2"
data_C = "*[" & data & "]*"
Case Else: Exit Sub
End Select
Application.EnableEvents = False
Range("A2:B65536").ClearContents
If data <> "" Then
Range(key) = data
For i = 3 To MySh2.Range("A65536").End(xlUp).Row
If MySh2.Cells(i, 1) Like data_C Then
With MySh2
.Cells(i, 1).Resize(, 2).Copy
With MySh1
.Cells(n, 1).PasteSpecial Paste:=xlPasteValues
End With
End With
n = n + 1
End If
Next i
End If
Application.EnableEvents = True
End Sub
（キリキ）(〃⌒o⌒)ｂ
略語が多すぎたのと、丁度検索文字が初めのＣとかＤとかの使用量の多いので 試してた為、Ａから始まる略語と重なってた様です。 Ａ２の検索は表示量が多すぎ、調べずらいと思ってましたが、別のブックに Sheet2のＡ列とＢ列を入れ替え和文(漢字一文字)から略語を調べるのに丁度良い ことが判りました。 使い勝手は前回書いて頂いたマクロ方がが良い様です。
お時間が有りましたらで結構です。 前回書いて頂いたマクロを変形させて、Sheet1のＡ２には英字検索、頭から数文字で Sheet2のＡ列から検索 Sheet1のＢ２には漢字検索、一文字で〜を含むをSheet2のＢ列から検索・・の場合で 一つのブックで、両側からの検索が出来のですが・・ 書いて頂ける場合には、前回のマクロの変形で違いの見比べが出来る程度だと助かります。お忙しいのでしたらもう充分ですよ本当に。 「略語→日本語検索辞書」と「日本語→略語辞書」の二つを一度手に入れてしまい、 驚いてます。有難う御座いました。 (橋の下から)
いや〜 宿題（希望）まで出して頂いて、こちらとしても感謝しております。 （嫌味とかではありませんよ〜♪ 勉強の機会を頂いて本当に嬉しいのです☆）
ご希望のものは、検索後に Sheet1のA2から表示していくのでいいのですよね？
Option Compare Text
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, n As Long
Dim Mydata(1 To 2) As String
Dim data As Variant, data_C As Variant, key As Variant
Dim MySh2 As Worksheet
Set MySh2 = Worksheets("Sheet2")
n = 3
Select Case Target.Address
Case "$B$2"
data = Mid(Target, 1, 1)
key = "B"
data_C = "*[" & data & "]*"
Case "$A$2"
data = Target
key = "A"
data_C = data & "*"
Case Else: Exit Sub
End Select
Application.EnableEvents = False
Range("A2:B65536").ClearContents
If data <> "" Then
Range(key & 2) = data
For i = 2 To MySh2.Range(key & "65536").End(xlUp).Row
If MySh2.Range(key & i) Like data_C Then
With MySh2
Mydata(1) = .Cells(i, 1)
Mydata(2) = .Cells(i, 2)
End With
Cells(n, 1) = Mydata(1)
Cells(n, 2) = Mydata(2)
n = n + 1
End If
Next i
End If
Application.EnableEvents = True
End Sub
希望通りに動けばいいのですが・・・ （キリキ）(〃⌒o⌒)b
パーフェクトです。希望通りの動きをしており驚いてます。 B2の検索には上の方に書いてある「一文字検索」の定義が入ってるのだと思いますが これを一文字検索にしない・・つまり、複数の文字で検索させるのにはどこかの列を 削除させるだけで出来るものなのでしょうか? それとも書き直し必要でしょうか? (橋の下から)
おはようございます。 一文字検索では無くしたいと言う事ですね？
では、
Set MySh2 = Worksheets("Sheet2")
n = 3
data = Target '←追加
Select Case Target.Address
Case "$B$2"
'data = Mid(Target, 1, 1) ←削除
key = "B"
'data_C = "*[" & data & "]*"←下記に変更
data_C = "*" & data & "*" '←[ ]を取る
Case "$A$2"
'data = Target ←削除
key = "A"
data_C = data & "*"
Case Else: Exit Sub
End Select
こんな感じに変更してみてください〜（＾＾）
後、ワイルドカード使用の検索もしてみてくださいね☆ 便利だと思いますよ〜♪
例：一日一善を調べたいが
~~~~
↑を忘れてしまった・・・
検索文字入力に 一*善 と入力
~~~
↑全角でも、半角でもＯＫ
＊ → 任意の数の文字
？ → 任意の 1 文字
※詳しくは、エクセルのヘルプで【ワイルドカード文字】で調べてください
（キリキ）(〃⌒o⌒)ｂ
長い間、本当に長い間ご教授ありがとう御座いました。 複数文字を含む検索も上記のまま書き直して、検索の早い辞書となりました。 【ワイルドカード文字】・・上の方に、 ※B1には、"*"や"?"も使用できるようです の意味がやっと解かりました。今まで「Ctrl+F」検索はしてましたがワイルドカード は知りませんでした。 初めに素人の為にAlt+F11の使い方から書いて頂いた弥太郎さん、素人に最後まで お付き合い頂いた キリキさん有難う御座いました。 この略語辞書の作成は全文大事に保存させて頂きます。 (橋の下から)
お礼を言われて、大変嬉しく思います。 初めて、本格的なマクロを作成したような気がしてドキドキでした(^^;) 何せ、元が弥太郎先生のコードですから、、、 緊張しました〜 とにかく、無事に解決できたようで何よりです〜♪
橋の下からさん、σ(^o^;)もあなたにお礼を言わせてください。 ありがとう
（キリキ）(〃⌒o⌒)ｂ
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.