[[20090722151922]]　『ｱﾙﾌｧﾍﾞｯﾄの後の数字を取り出す』（困困）　ページの最後に飛ぶ

『ｱﾙﾌｧﾍﾞｯﾄの後の数字を取り出す』（困困）

 以前、困っているところ助けていただきありがとうございます。
 化学式で元素（C,H,N,S,Na等）の後の数値を取り出すﾏｸﾛをご教授願います。
 なお、数値は半角で下付き文字にはしていません。
 例1
     A          B       C      
 1  C5H11O2N    c       5
 2              H      11
 3              O       2
 4              N       1

例2

     A              B       C      
 1  C14H14O3N3Na    c      14
 2                  H      14
 3                  O       3
 4                  N       3
 5                  Na      1

 B列の並びは何時も同じ並びではありません。
 よろしくお願いします。

 これで試してください。

 UDFです
 1) Alt + F11 でVBEを起動
 2) [挿入] - [標準モジュール], 右空白部分に下記コードを貼り付ける
 3) Alt + F11 でエクセル画面に戻る
 セルに
 =ChemicalSign($A$1,Column(A1),Row(A1))
 として、右/下にコピー

 Function ChemicalSign(ByVal txt As String, ByVal Ind As Long, ByVal ref As Long)
 ChemicalSign = 0
 With CreateObject("VBScript.RegExp")
     .Pattern = "([A-Z][a-z]?)(\d+)?"
     .Global = True
     If .test(txt) Then
         ChemicalSign = .execute(txt).item(Ind - 1).submatches(ref - 1)
     End If
 End With
 End Function
 (seiya)

 （困困）
 seiya様　
 確認遅くなりすみません。

 行に回答が出来るんですね。
 良かったら、ｺｰﾄﾞの意味、下記部分について教えていただけないでしょうか。

　　 .Pattern = "([A-Z][a-z]?)(\d+)?"

     .Global = True
     If .test(txt) Then
         ChemicalSign = .execute(txt).item(Ind - 1).submatches(ref - 1)

 「正規表現」(Regular Expression)を調べてください。
 (seiya)

seiya様

 「正規表現」(Regular Expression)････こんなｵﾌﾞｼﾞｪｸﾄがあるとは････
 勉強になります。
 RegExpｵﾌﾞｼﾞｪｸﾄを使って、物質検索ﾏｸﾛを作成したいです。
 また、解らないことがあれば、ご教授願います。 
 (困困)

 困困様、seiya様

 VBAを始めたばかりの「Chem坊」といいます。

 困困様、その後化学物質の検索ﾏｸﾛは完成されたのでしょうか。その後、スレが出れば
 私も、一緒に勉強させていただくつもりでしたが、出ないので皆さんにご教示していただきたく
 便乗させていただきました。

 他のsheet「一覧表」のB列4行目以降に化学式があります。（ただし、ｱﾙﾌｧﾍﾞｯﾄは必ずしも順に並んでいない）
 検索ｼｰﾄから、順に「C14」、「H14」、「O3」、「N3」、「Na」と検索して、一致した化学式を取り出したいです。
 他にも、良い方法がありましたらよろしくお願いいたします。
 (Chem坊)

 困困様、seiya様

 記述不足の箇所がありました。

他のsheet「一覧表」のB列4行目以降に化学式があります。（ただし、ｱﾙﾌｧﾍﾞｯﾄは必ずしも順に並んでいない）検索ｼｰﾄから、順に「C14」、「H14」、「O3」、「N3」、「Na」と検索して、一致した化学式を取り出したいです。

 上記は困困さんの、例2をとりあげて質問させていただきました。
 また、スレでなくレスだったんですね。スレだと理解してました。（汗）
 きおつけ～！礼！　それではよろしくお願いします。
 (Chem坊)

 Chem坊さんの求めている結果を取り違えていたらごめんなさい。

 Sub try()
   Dim myReg As Object
   Dim st As String, ss As String
   Dim v As Variant

   Set myReg = CreateObject("VBScript.RegExp")
   myReg.Pattern = "([A-Z][a-z]*\d+|[A-Z][a-z]*)"
   myReg.Global = True

   st = "C14H14O3N3Na"
   If myReg.Test(st) Then
      For Each v In myReg.Execute(st)
          ss = ss & vbLf & v
      Next
   End If
   MsgBox st & vbLf & ss
   Set myReg = Nothing
 End Sub

 こんな感じの事をしたいのかなって思いましたが、どのようなデータから
 どのような結果を返したいのかを、明確にされた方が宜しいかも知れません。

 （じゅんじゅん）

（じゅんじゅん）

 どうも、説明が上手く出来ずすみません。						
 こんな感じです。						
 Sheet(1)のA1に化学式を入力して、分解した値をB1以降に抽出もしくは保持する。						
 Sheet(2)のA列の物質名から検索、検索されたｾﾙをｱｸﾃｨﾌﾞにする。
 (ただし、並びの異なる場合も同じとして検出する）

 Sheet(1)						
	A	          B	 C	D	E	F
 1	C14H14O3N3Na	C14	H14	O3	N3	Na

 Sheet（2）						
	A	          B	 C	D	E	F
 1	化学式					
 2	C6H10O3	
 3	C8H11NO	
 4	C14H14N3O3Na	←このような並びの異なる場合も同じとして検出
 5	C2Cl4	
 6	C2HBrF	
 7	C4H5NO2	
 8	C9H20O3	
 9	C2H5ON	
 10	・・・・・・・	
 11	・・・・・・・

 まだまだ、説明が不足しているかもしれませんが、よろしくお願いします。		
  (Chem坊）

 1) B1 から 抽出セル数を選択
 2) =myMatch(A1,Sheet2!A1:A100)
     として、Ctrl + Shift + Enter で確定 (配列数式)

 で試してください。

 Function myMatch(ByVal txt As String, rng As Range) As Variant
 Dim a, b(), i As Long, m As Object, flg As Boolean
 a = rng.Columns(1).Value
 With CreateObject("VBScript.RegExp")
     .Pattern = "^([A-Z][a-z]?\d+?)+$"
     .Global = True
     For i = 1 To UBound(a, 1)
         If .test(txt) Then
             For Each m In .execute(txt)
                 .Pattern = m.Value
                 If Not .test(m.Value) Then
                     Exit For : flg = True
                 End If
             Next
             If Not flg Then
                 myMatch = i
                 Exit For
             End If
         End If
         flg = False
     Next
     If Not IsEmpty(myMatch) Then
         txt = a(i, 1)
         .Pattern = "[A-Z][a-z]?\d+?"
         Set m = .execute(txt)
         ReDim b(m.Count - 1)
         For i = 0 To m.Count - 1
             b(i) = m.item(i)
         Next
     End If
 End With
 myMatch = IIf(IsEmpty(myMatch), CVErr(xlErrNA), b)
 End Function
 (seiya) '署名追加

　(じゅんじゅん）さん

　先程は、大変ご無礼をしました。（じゅんじゅん）と呼び捨てにしておりました。

　今回のFunction　ﾌﾟﾛｼｰｼﾞｬｰ、少し教えていただきたいのですがよろしいでしょうか。

 　1) B1 から 抽出セル数を選択　←　理解力なくすみませんが、どんな意味でしょうか			
 　2) =myMatch(A1,Sheet2!A1:A100)			　←　Sheet1の　B1へ入力するのですよ　ね。
     として、Ctrl + Shift + Enter で確定 (配列数式)

　B1ｾﾙから下へ2）の式を配列変数で入力していますが、「＃N/A」になります。
　functionﾌﾟﾛｼｰｼﾞｬで作成されたｺｰﾄﾞの検証は、どのような方法で出来るのでしょうか？

　また、SUBﾌﾟﾛｼｰｼﾞｬで作成すると、どのようになるのでしょうか。？
　沢山の質問ばかりですみませんが、よろしくお願いいたします。
　（Chem坊）

 > 　1) B1 から 抽出セル数を選択　←　理解力なくすみませんが、どんな意味でしょうか	
 B1からF1（若しくは、抽出されるべきセル数)という意味です。
 (seiya)

 >また、SUBﾌﾟﾛｼｰｼﾞｬで作成すると、どのようになるのでしょうか。？ 　
 とりあえず、上記で機能するか試してからにしてください。
 (seiya)

 seiya様

 回答していただいていたのは、seiya様だったんですね。
 ありがとうございます。じゅんじゅんさん感謝です。

 先日、質問してから出張がありまして、今朝拝見したところです。
 (返事遅くなり、申し訳ﾘません）
 seiya様、確認ですがご指導どうりsheet1のB1～F1（この例の場合）配列数式を入力しましたが、「#N/A」が表示されます。

 Functionﾌﾟﾛｼｰｼﾞｬのﾃﾞﾊﾞｯｸﾞ方法をご教示ねがえれば助かります。（調べたのですが分かりません）
 また、検索してﾋｯﾄしたｾﾙをｱｸﾃｨﾌﾞにするのは、今後と言うことでしょうか？
 よろしくお願いします。
 (Chem坊)

 Function のDebug の方法は
 まず、Break Point を設定します。

 コード中の
 a = rng.Columns(1).Value
 の左側のProject Explorer と Code pane の境界をクリックすると
 ●(黒ではありませんが)ができます。

 もし、上記がわからなければ
 a = rng.Columns(1).Value
 Stop  '<- 挿入
 してください。

 シートに戻って、もう一度範囲を選択して数式バーをクリックして Ctrl + Shift + Enter
 で確定すると、Break Point を設定した行でDebug mode になります。
 (seiya)

 seiya様

 Debug方法を教えていただきありがとうございます。

 早速、Debag行いました。
 これまで方法も分からなかったのに、Debugできてうれしいです。

 結果：myMatchにｴﾗｰ「2042」が出ます。
 Sheet2のA4の「C14H14N3O3Na」を「C14H14O3N3Na」へ変更してみましたが、結果は同じです。
 ちなみに、ｍはNothingでした。
 seiya様　よろしくお願いします。
 (Chem坊)

 そうでしたか、
 その前に
 C2HBrF
 はどのように分解するのでしょう？
 (seiya)

 seiya様

 C2HBrFの分解の件ですが、B1:C2, C1:H, D1:Br, E1:F このようになります。
 数字がない場合は、H*1=H　のようにです。（C2HBrF→C2H1Br1F1のように解釈できます）
 (Chem坊)

 これでどうでしょう？

 MsgBox を仕掛けましたので、読んでいただけますか？
 それと"様" は止しましょう。

 Function myMatch(ByVal txt As String, rng As Range) As Variant
 Dim a, b(), i As Long, m As Object, flg As Boolean
 a = rng.Columns(1).Value
 With CreateObject("VBScript.RegExp")
     .Pattern = "^([A-Z][a-z]?\d+?)+$"
     .Global = True
     MsgBox "Pattern: ^([A-Z][a-z]?\d+?)+$" & vbLf & .test(txt)
     For i = 1 To UBound(a, 1)
         If .test(txt) Then
             For Each m In .execute(txt)
                 .Pattern = m.Value
                 If Not .test(m.Value) Then
                     Exit For : flg = True
                 End If
             Next
             If Not flg Then
                 myMatch = i
                 Exit For
             End If
         End If
         flg = False
     Next
     If Not IsEmpty(myMatch) Then
         txt = a(i, 1)
         .Pattern = "[A-Z][a-z]?\d+?"
         Set m = .execute(txt)
         ReDim b(m.Count - 1)
         For i = 0 To m.Count - 1
             b(i) = m.item(i)
         Next
     End If
 End With
 myMatch = IIf(IsEmpty(myMatch), CVErr(xlErrNA), b)
 End Function
 (seiya)

 seiyaさん
　
 >"様" は止しましょう。････以後、”seiyaさん”で行かせていただきます。

 >MsgBox を仕掛けましたので、読んでいただけますか？
 MsgBox内容見ますが、”False”になっています。
 その他の、ｺｰﾄﾞは変更なしなのですね。
 (Chem坊)

 > MsgBox内容見ますが、”False”になっています

      .Pattern = "^([A-Z][a-z]?\d+?)+$"
 がヒットしていないようですね...

      .Pattern = "([A-Z][a-z]?\d+?)"
 にして試していただけますか？
 (seiya)

 横から失礼します。

 seiyaさんへ

 >.Pattern = "([A-Z][a-z]?\d+?)"
 の場合ですと、
 C14 → C1  Na → 該当しない となるようです。

 ”数字が１個以上ある事”で成立し、且つ”数字は１個だけ”選ばれる感じです。
 ⇒ただ私が試していたコードでの検証です。

 そのコードでヒット出来たパターンは
 　myReg.Pattern = "([A-Z][a-z]?)(\d+)?"
 でした。
 （じゅんじゅん）

 じゅんじゅんさん、ありがとうございます。
 そうですか。

 Chem坊さん
 .Pattern = "([A-Z][a-z]?)(\d+)?"
 で試してください。

 でも私には
 .Pattern = "([A-Z][a-z]?\d+?)"
 .Pattern = "([A-Z][a-z]?)(\d+)?"
 の違いがわからないのですが...
 (seiya)

 >の違いがわからないのですが...
 私も自信はありません・・・

 ただ数字部分が”１個以上の集まりが、０回又は１回”と言う感じになるのかなって
 思っているくらいですが、正直"?"の使い方ってまだわかってません。

 （じゅんじゅん）

 > ただ数字部分が”１個以上の集まりが、０回又は１回”と言う感じになるのかなって
 あっ、そうです！
 ありがとうございます。
 (seiya)

 seiyaさん、じゅんじゅんさん

 衝突しちゃったようです。
 >.Pattern = "([A-Z][a-z]?)(\d+)?"
 で試してください。
 早速試してみました。じゅんじゅんさんの言われるﾊﾟﾀｰﾝでやってみました。
 すこし、躓きましたがMsgはTrueが返りました。(躓き：Exit For、Next････必要とは思いますが？）
 動作状況は、以下のｺｰﾄﾞに書き入れています。
 今度は、Sheet1のB1セル以下が「#VALUE!」になりました。

 Function myMatch(ByVal txt As String, rng As Range) As Variant
 Dim a, b(), i As Long, m As Object, flg As Boolean
 a = rng.Columns(1).Value
 With CreateObject("VBScript.RegExp")
     '.Pattern = "^([A-Z][a-z]?\d+?)+$"
     .Pattern = "([A-Z][a-z]?)(\d+)?"

     .Global = True
     'MsgBox "Pattern: ^([A-Z][a-z]?\d+?)+$" & vbLf & .Test(txt)
     MsgBox "Pattern: ^([A-Z][a-z]?)(\d+)?" & vbLf & .Test(txt)
         If .Test(txt) Then
             For Each m In .Execute(txt)
                 .Pattern = m.Value
                 If Not .Test(m.Value) Then
                     Exit For: flg = True
                 End If
             Next
             If Not flg Then
                 myMatch = i
                 'Exit For　←"For Next内に対応するExit Forがありません”て出るので外しました。
             End If
         End If
         flg = False
     'Next　　　　←Exit Forを外したところ"Nextに対応するForがありません"と出るので外しました。
     If Not IsEmpty(myMatch) Then
         txt = a(i, 1)　　・・・・・←このｺｰﾄﾞを過ぎると、一気に終了する。
         .Pattern = "[A-Z][a-z]?\d+?"
         '.Pattern = "([A-Z][a-z]?)(\d+)?"

         Set m = .Execute(txt)
         ReDim b(m.Count - 1)
         For i = 0 To m.Count - 1
             b(i) = m.Item(i)
         Next
     End If
 End With
 myMatch = IIf(IsEmpty(myMatch), CVErr(xlErrNA), b)
 End Function

 seiyaさん、じゅんじゅんさん、　よろしくお願いします。
 (Chem坊)

 ひっちゃかめっちゃかになっていましたね...
 すみません

 これで試してください。

  Function myMatch(ByVal txt As String, rng As Range) As Variant
 Dim a, b(), i As Long, m As Object, flg As Boolean
 a = rng.Columns(1).Value
 With CreateObject("VBScript.RegExp")
     .Pattern = "([A-Z][a-z]?)(\d+)?"
     .Global = True
     If .Test(txt) Then
         For i = 1 To UBound(a, 1)  '<- 修正 17:10
             For Each m In .Execute(txt)
                 .Pattern = m.Value
                 If Not .Test(a(i, 1)) Then
                     flg = True : Exit For  '<- 修正 16:34
                 End If
             Next
             If Not flg Then
                 myMatch = i : Exit For
             End If
             flg = False
         Next
         If Not IsEmpty(myMatch) Then
             .Pattern = "([A-Z][a-z]?)(\d+)?"
             Set m = .execute(a(i, 1))
             ReDim b(m.count - 1)
             For i = 0 To m.count - 1
                 b(i) = m.item(i)
             Next
         End If
     End If
 End With
 myMatch = IIf(IsEmpty(myMatch), CVErr(xlErrNA), b)
 End Function

 全体は見てないのですが一点だけ気になったので
　
ここの
             For Each m In .Execute(txt)
                 .Pattern = m.Value
                 If Not .Test(m.Value) Then
                     Exit For: flg = True
                 End If
             Next
の、 
    Exit For: flg = True
で、flg = True は通らないけれど良いのかな？と。
（ご近所PG）思った

 ご近所PGさん
 ありがとうございます。
 修正しました。
 (seiya)

 >For i = 1 To UBound(a(, 1))
 For i = 1 To UBound(a, 1)
 でしょうか。

 こちらでは
 C14H14O3N3Na　⇒　C14　H14　N3　O3　Na
 と結果がでました。

 ご報告まで。
 （じゅんじゅん）

 またまた、ありがとうございます。

 コード修正しておきます。
 (seiya)

 seiyaさん、じゅんじゅんさん、そしてご近所PGさん

 皆さんお世話になります。
 またまた、衝突しちゃったようです。
 きちんと対応する物質が出せました。
 ありがとうございます。

 ただし、私の作成した例が悪くて申し訳ないのですが、Sheet2のA列にはC14H････という物質が沢山あって、その中から該当する物質を抽出する必要があります。
 下記にSheet2のA列の例を再掲します。
 (再掲）
　 Sheet(1)						
	A	          B	 C	D	E	F
 1	C14H14O3N3Na	C14	H14	O3	N3	Na

 Sheet（2）						
	A	          B	 C	D	E	F
 1	化学式					
 2	C6H10O3	
 3	C8H11NO	
 4	C14H18N2O2	←最初C14で候補には上がる。
 5	C2Cl4	
 6	C2HBrF	
 7	C14H8N4O5F3	
 8	C9H20O3	
 9	C2H5ON	
 10	C14H14N3O3Na	←このような並びの異なる場合も同じとして検出
 11	C4H4Cl2

 こんな感じで、多くの物質があります。（上記例はむちゃくちゃですが・・・・）
 それにしても皆さんの、直ぐの対応感服するばかりです。
 (Chem坊）

 えーーと、よく意味がわからないのですが...

 10	C14H14N3O3Na

 とマッチするのを確認して、

 1	C14H14O3N3Na

 を分解するのではないのですか？
 現在のコードでは  10	C14H14N3O3Na を分解してしまっていますが...

 > Set m = .execute(a(i, 1))
 を
 Set m = .execute(txt)

 に変更すれば
 1	C14H14O3N3Na
 の方を分解します。

 (seiya)

 seiyaさん

 説明が不足しても仕分けありません。

 検索で並びの異なるSheet1のA1と、Sheet2のA10が一致することを確認して
 Sheet2のA10をｱｸﾃｨﾌﾞにしたいのです。
 そのためには、Sheet1のA1を分解して、C14→H14→････というように、
 C14に該当する物質を全て取り出して、 取り出した物質をH14で一致するものを
 抜出し、さらに抜出した物質からN3を有する物質を取り出して、
 最終的には並びは違ってもそれぞれのｱﾙﾌｧﾍﾞｯﾄの後ろの数字がおなじであれば、
 同物質として抽出したいのです。

 (Chem坊)

 ということは、

 1	C14H14O3N3Na

 とSheet2 のA列の各分子?がすべて一致する行番号(10)を知りたい

 ということですか？

 Function myMatch(ByVal txt As String, rng As Range) As Variant
 Dim a, b(), i As Long, m As Object, flg As Boolean
 a = rng.Columns(1).Value
 With CreateObject("VBScript.RegExp")
     .Pattern = "([A-Z][a-z]?)(\d+)?"
     .Global = True
     If .Test(txt) Then
         For i = 1 To UBound(a, 1)
             If Len(txt) = Len(a(i, 1)) Then
                 For Each m In .Execute(txt)
                     .Pattern = m.Value
                     If Not .Test(a(i, 1)) Then
                         flg = True : Exit For
                     End If
                 Next
                 If Not flg Then
                     myMatch = i : Exit For
                 End If
                 flg = False
             End If
         Next
     End If
 End With
 myMatch = IIf(IsEmpty(myMatch), CVErr(xlErrNA), myMatch)
 End Function

 それとも、

 1	C14H14O3N3Na

 の各分子?がA列のどこかにあればその分子を列記？

 ですか？
 (seiya)
 コード修正 18:43

 seiyaさんのコードを使わせて頂きました。

 Sub try()
     Dim myAdd As Variant

     'ワークシート２のＡ列の範囲は適宜修正で
     myAdd = myMatch2(Worksheets("Sheet1").Range("A1").Value, _
                     Worksheets("Sheet2").Range("A1:A100"))

     If IsError(myAdd) Then MsgBox "見つからないです": Exit Sub
     Worksheets("Sheet2").Activate
     Range("A" & myAdd).Select
 End Sub

 Function myMatch2(ByVal txt As String, rng As Range) As Variant
     Dim a, b(), i As Long, m As Object, n As Object, flg As Boolean '<-変数　n　追加
     a = rng.Columns(1).Value
     With CreateObject("VBScript.RegExp")
          .Pattern = "([A-Z][a-z]?)(\d+)?"      '<-元の位置に
          .Global = True
          If .Test(txt) Then
              Set n = .Execute(txt)             '<-追加
              For i = 1 To UBound(a, 1)
                  For Each m In n               '<-修正
                      .Pattern = m.Value
                      If Not .Test(a(i, 1)) Then
                         flg = True: Exit For
                      End If
                  Next
                  If Not flg Then
                     myMatch2 = i: Exit For
                  End If
                  flg = False
              Next
              'If Not IsEmpty(myMatch) Then
              '   .Pattern = "([A-Z][a-z]?)(\d+)?"
              '   Set m = .Execute(a(i, 1))
              '   ReDim b(m.Count - 1)
              '   For i = 0 To m.Count - 1
              '       b(i) = m.Item(i)
              '   Next
              'End If
          End If
     End With
     myMatch2 = IIf(IsEmpty(myMatch2), CVErr(xlErrNA), i)
  End Function

 8/27 21:23　修正

 マクロ"try"を実行して下さい。
 ⇒シート２のＡ列を選択出来ればいいのですよね？
 （じゅんじゅん）

 > 検索で並びの異なるSheet1のA1と、Sheet2のA10が一致することを確認して
 > Sheet2のA10をｱｸﾃｨﾌﾞにしたいのです。

 でしたね...

 私は
	A	          B	 C	D	E	F
 1	C14H14O3N3Na	C14	H14	O3	N3	Na
                           ^^^^      ^^^^    ^^^      ^^^       ^^
 これが最後まで引っかかってました。

 (seiya)

 seiyaさん
 3度目の衝突です。←ちょっと凄いですね。

 >1　　　　C14H14O3N3Na
 >とSheet2 のA列の各分子?がすべて一致する行番号(10)を知りたい
 そうです。並びが違っても一致する物質を抽出（ｱｸﾃｨﾌﾞ）にしたいのです。
 ｺｰﾄﾞこれから、確認してみます。←すみません、あすになります。ごめんなさい！

 じゅんじゅんさん
　
 早速の対応ありがとうございます。
 試したところ、最初のC14を含む物質に当たりつくようです。
 並びは違っても次のH,N,O等の数が全て同じものを抽出したいです。

 これから、退社の予定なので、確認はあすになります。
 seiyaさん、じゅんじゅんさんありがとうございました。
 今日は、これで失礼します。
 (Chem坊)

 i = 1 の　.Execute(txt)　に対しての　pattern　は

 .Pattern = "([A-Z][a-z]?)(\d+)?"

 ですがi = 2 以降【配列変数：a】での　pattern　は

  .Pattern = m.Value

 になっているようですので修正してみました。
 （じゅんじゅん）

 修正してみましたが何か違っているようです。。。。。（じゅんじゅん）

 お邪魔でなければいいのですが・・・
 ちょっと違ったアプローチといいますか
 私自身が正規表現が苦手なのもあって順当に文字列処理でやってみたので
 参考程度にアップさせてください。

  Sub test()
  Dim a As Variant, b As Variant, v As Variant
  Dim i As Long, j As Long, Hit As Long
  With Worksheets("Sheet1")
    .Range("B1", .Range("B1").End(xlToRight)).ClearContents
    a = StrSplit(.Range("A1").Value)
    .Range("B1").Resize(, UBound(a) + 1).Value = a
  End With
  mySort a
  v = Worksheets("Sheet2").Range("A1").CurrentRegion.Value
  For i = 1 To UBound(v)
    b = StrSplit(CStr(v(i, 1)))
    If UBound(a) = UBound(b) Then
      mySort b
      Hit = 0
      For j = 0 To UBound(a)
        If a(j) = b(j) Then
          Hit = Hit + 1
        Else
          Exit For
        End If
      Next j
      If Hit = UBound(a) + 1 Then
        With Worksheets("Sheet2")
          .Select
          .Range("A" & i).Select
        End With
        Exit Sub
      End If
    End If
  Next i
  End Sub

  Private Sub mySort(ByRef ary As Variant)
  Dim i As Long, j As Long, buf As String
  For i = 0 To UBound(ary)
    For j = i + 1 To UBound(ary)
      If ary(i) > ary(j) Then
        buf = ary(j): ary(j) = ary(i): ary(i) = buf
      End If
    Next j
  Next i
  End Sub

  Private Function StrSplit(strDat As String) As Variant
  Dim i As Long, strBuf As String
  For i = 1 To Len(strDat)
    strBuf = Mid$(strDat, i, 1)
    StrSplit = StrSplit & IIf(strBuf Like "[A-Z]", "," & strBuf, strBuf)
  Next i
  StrSplit = Split(Mid$(StrSplit, 2), ",")
  End Function

 （ｍｏｍｏ）

 修正しました。（じゅんじゅん）

 seiyaさん、じゅんじゅんさん、m o m oさん

 皆さんお早うございます。

 皆さんに作成していただいた、ﾏｸﾛ全てが目的の物質を抽出しました。
 長時間にわたって付き合っていただきありがとうございました。
 次回の質問では、もっと皆さんに早く理解していただけるようにしたいと思います。

 VBA初心者ですが、これを機会に勉強したいと思います。
 (Chem坊)

コメント返信：

[ 一覧(最新更新順) ]

[[20090722151922]] 『ｱﾙﾌｧﾍﾞｯﾄの後の数字を取り出す』（困困） ページの最後に飛ぶ

[[20090722151922]]　『ｱﾙﾌｧﾍﾞｯﾄの後の数字を取り出す』（困困）　ページの最後に飛ぶ