- ベストアンサー
Ｅｘｃｅｌのセルに有る文字列の切り分けの仕方
ＭＩＤを使ってやってみましたが、思った通りの結果が得られなかったので、ご質問させていただきます。 セルのL１、M1に★・・・、●・・・・・、▲・・・・・・、★・・、と言うような文字列が入っております。（これはその時により異なりますが、ＭＡＸでＬ100ぐらいになり、記号もセル内で複数回出現、・は定数ではありません） それをL1に有る★以降次の記号までの文字列をＯ1に、●以降をＰ1に、▲以降をＱ1に、 同じくＭ1に有る文字列もＲ１、Ｓ1、Ｔ1に文字列を ボタン１つで入れたいのですが、どの様に関数又は ＶＢＡで組んだらいいのでしょうか？よろしくお願いいたします。
- みんなの回答 （6）
- 専門家の回答
質問者が選んだベストアンサー
その他の回答 (5)
- Wendy02
- ベストアンサー率57% (3570/6232)
- Wendy02
- ベストアンサー率57% (3570/6232)
こんにちは。 #2のWendy02です。 まあ、ぶつかっても、それは、ご本人が考えればよいことですので、あとはユーザー設定で、都合が悪ければ、書き換えればよいとします。 コードの「貼り付け左端上」のところに書いていただければよいです。なお、マークに関しては、「マーク」という所に、切り分け文字を入れればよいです。 「★・・・、●・・・・・、▲・・・・・・、★・・、」 この順序は問いません。後は、フォーム・ツールのボタンにでも取り付けてください。 '標準モジュール '---------------------------------------- Sub TestSplitting() Dim sRng As String Dim strRngs As Variant Dim strPasteRngs As Variant Dim rng As Variant Dim c As Range Dim i As Integer Dim j As Long 'データの先頭位置 Const MYRANGE_TOP As String = "L1,M1" strRngs = Split(MYRANGE_TOP, ",") '切り分け '貼り付け左端 Const MYPASTE_RANGE As String = "O1,R1" strPasteRngs = Split(MYPASTE_RANGE, ",") '切り分け Application.ScreenUpdating = False For Each rng In strRngs For Each c In Range(Range(rng), Cells(65536, Range(rng).Column).End(xlUp)) If Not IsEmpty(c) Then SplitMarks c, Range(strPasteRngs(i)).Offset(j) j = j + 1 End If Next i = i + 1 j = 0 Next Application.ScreenUpdating = True End Sub Private Sub SplitMarks(ByVal myRange As Range, myPasteRange As Range) Dim Matches As Object Dim Match As Object Dim i As Long Dim ArrayBuf() As Variant 'マーク Const MARKS As String = "★●▲" With CreateObject("VBScript.RegExp") .Global = True .Pattern = "([" & MARKS & "][^" & MARKS & "]+)" Set Matches = .Execute(myRange.Value) For Each Match In Matches ReDim Preserve ArrayBuf(i) ArrayBuf(i) = Match.Value i = i + 1 Next End With myPasteRange.Resize(, UBound(ArrayBuf) + 1) = ArrayBuf() End Sub '----------------------------------------
補足
丁寧なご回答ありがとうございます。もう少し甘えさせていただきたいのですが、書いていただいたプログラムですがＶＢエディターをおこしたときに表示されているPrivate Sub CommandButton2_Click() ＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊ End Sub の部分の＊のところに貼り付けそれをボタンに当込めばよろしいのでしょうか？、知識がなくてスイマセン！
- Wendy02
- ベストアンサー率57% (3570/6232)
補足
Wendy02様 度々で大変申し訳ございません。 ご指示のようにやってみた?ところ、「インデックスが有効範囲にありません」とのエラーが出ます。 現在MVE上で書かれているのは 下記のような形です。 私の作業手順が悪いのだと思いますが、どこをいじればよろしいのでしょうか? ご指導下さいよろしくお願い致します。 Private Sub CommandButton2_Click() Call TestSplitting End Sub Sub TestSplitting() Dim sRng As String Dim strRngs As Variant Dim strPasteRngs As Variant Dim rng As Variant Dim c As Range Dim i As Integer Dim j As Long 'データの先頭位置 Const MYRANGE_TOP As String = "L1,M1" strRngs = Split(MYRANGE_TOP, ",") '切り分け '貼り付け左端 Const MYPASTE_RANGE As String = "O1,R1" strPasteRngs = Split(MYPASTE_RANGE, ",") '切り分け Application.ScreenUpdating = False For Each rng In strRngs For Each c In Range(Range(rng), Cells(65536, Range(rng).Column).End(xlUp)) If Not IsEmpty(c) Then SplitMarks c, Range(strPasteRngs(i)).Offset(j) j = j + 1 End If Next i = i + 1 j = 0 Next Application.ScreenUpdating = True End Sub Private Sub SplitMarks(ByVal myRange As Range, myPasteRange As Range) Dim Matches As Object Dim Match As Object Dim i As Long Dim ArrayBuf() As Variant 'マーク Const MARKS As String = "★●▲" With CreateObject("VBScript.RegExp") .Global = True .Pattern = "([" & MARKS & "][^" & MARKS & "]+)" Set Matches = .Execute(myRange.Value) For Each Match In Matches ReDim Preserve ArrayBuf(i) ArrayBuf(i) = Match.Value i = i + 1 Next End With myPasteRange.Resize(, UBound(ArrayBuf) + 1) = ArrayBuf() End Sub '----------------------------------------