Ｅｘｃｅｌのセルに有る文字列の切り分けの仕方

質問

ＭＩＤを使ってやってみましたが、思った通りの結果が得られなかったので、ご質問させていただきます。
セルのL１、M1に★・・・、●・・・・・、▲・・・・・・、★・・、と言うような文字列が入っております。（これはその時により異なりますが、ＭＡＸでＬ100ぐらいになり、記号もセル内で複数回出現、・は定数ではありません）
それをL1に有る★以降次の記号までの文字列をＯ1に、●以降をＰ1に、▲以降をＱ1に、
同じくＭ1に有る文字列もＲ１、Ｓ1、Ｔ1に文字列を
ボタン１つで入れたいのですが、どの様に関数又は
ＶＢＡで組んだらいいのでしょうか？よろしくお願いいたします。

回答No.6

Wendy02 · ベストアンサー

こんばんは。
Wendy02です。

「インデックスが有効範囲にありません」

原因は、おそらくは、「 "★●▲"」という切り分けマークが必ずしも入っているとは限らない、ということですね。とりあえず、応急処置だけになります。

Private と名前のついてコードから下を以下に、差し替えしてみてください。

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
Dim buf 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
　　On Error Resume Next
　　buf = ArrayBuf(0)
　　If Err.Number = 0 Then
　　　　myPasteRange.Resize(, UBound(ArrayBuf) + 1) = ArrayBuf()
　　Else
　　　　myPasteRange.Value = myRange.Value
　　End If
　　On Error GoTo 0
End Sub

回答No.5

Wendy02

こんにちは。
#3の　Wendy02です。返事が遅くなりました。
私の書いたマクロを標準モジュールに登録しましたら、後は、

Private Sub CommandButton2_Click()
　Call TestSplitting
End Sub

としてみてください。

補足

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
'----------------------------------------

回答No.4

noname#22222

s_husky です。

少し、補足しておきます。

　　[　　A ][　　　　B　　　　　]
１　○AAA　BBBB☐CCCC
２　△BBBB
３　☐CCCC

これは、Excel で　B1　に表示したものです。

B1の数式=CutStr(A1 & A2 & A3, "△", 2)

CutStrの第一引数の文字列の合成については自力で工夫して下さい。

回答No.3

Wendy02

こんにちは。

#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
の部分の＊のところに貼り付けそれをボタンに当込めばよろしいのでしょうか？、知識がなくてスイマセン！

回答No.2

Wendy02

こんにちは。

一応、考えてみましたが、ロジックとしては、ちょっとおかしな部分がありますね。

★・・・、●・・・・・、▲・・・・・・、★・・、

これですと、4個のセルが必要ですね。
それを、O1,P1,Q1,R1 まで必要となるのに、

M1に同様にあるものを、
R1,S1,T1 としたら、ぶつかってしまいますね。
なお、切り分けるのは、正規表現のほうが簡単でしょうね。

回答No.1

noname#22222

Public Function CutStr(ByVal Text As String, _
　　　　　　　　　　　 ByVal Separator As String, _
　　　　　　　　　　　 ByVal N As Integer) As String
　　Dim strDatas() As String

　　strDatas = Split("" & Separator & Text, Separator, , 0)
　　CutStr = strDatas(N * Abs((N <= UBound(strDatas))))
End Function

? CutStr("AAA,BBB,CCC", ",", 2)
BBB

? CutStr("THIS IS A PEN.", " ", 2)
IS

? CutStr("THIS IS A PEN.", "THIS ", 2)
IS A PEN

? CutStr("THIS IS A PEN.", "IS ", 1)
THIS

私にとって、必須の関数です。

＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
"AAAA○BBBB△CCCC" から BBBB を抜き出す用法
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊

? CutStr("AAAA○BBBB△CCCC", "○", 2)
BBBB△CCCC

? CutStr("BBBB△CCCC", "△", 1)
BBBB

よって、

? CutStr(CutStr("AAAA○BBBB△CCCC", "○", 2), "△", 1)
BBBB