[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『括弧内の文字列を抜き出す』（boruto77）
単一セルの文字列をカッコ内の文字とそれ以外の文字にそれぞれ別のセルに分割するVBAのコード
但し､カッコは文字列の後方からを優先とする
例えば、A1に「北海道（ほかいどう）観光（匿名）」ならB1に「北海道（ほかいどう）観光」、C1に「匿名」と分割
現在の以下のコードを利用していますが
コードを以下の色んなカッコ及び全角、半角のどちらにも対応するようにしたい
「」 ･･･ かぎかっこ
（） ･･･ かっこ
〈〉 ･･･ やまかっこ
《 》 ･･･ 二重山括弧（にじゅうやまかっこ）
〔〕 ･･･ きっこう
【】 ･･･ すみつきかっこ
｛｝ ･･･ 中かっこ
［］ ･･･ 大かっこ
Option Explicit
Sub CellSplitwithoutKTUKO()
Dim str As String
Dim openPos As Integer
Dim closePos As Integer
Dim i As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To LastRow
str = Cells(i, "A").Value
' Find the position of the last opening parenthesis
openPos = InStrRev(str, "(")
' Find the position of the last closing parenthesis
closePos = InStrRev(str, ")")
' If there are no parentheses, exit the sub
If openPos = 0 Or closePos = 0 Then
Exit Sub
End If
' If the closing parenthesis comes before the opening parenthesis, exit the sub
If closePos < openPos Then
Exit Sub
End If
' Split the string into two parts
Cells(i, "B").Value = Left(str, openPos - 1)
Cells(i, "C").Value = Mid(str, openPos + 1, closePos - openPos - 1)
Next
End Sub
＜ 使用 Excel：Excel2021、使用 OS：Windows11 ＞
カッコの左と右が別書種類のカッコということはありますか？ また、カッコが片方だけということはありますか？ また、カッコの左と右が逆ということはありますか？ カッコが入れ子になってることはありますか？ （MK） 2023/07/10(月) 07:20:34
以下の問いに付き回答いたします。
カッコの左と右が別書種類のカッコということはありますか？
ありません。 （左右で対で同一の種類の括弧）
また、カッコが片方だけということはありますか？
ありません。 （左右で対で使用）
また、カッコの左と右が逆ということはありますか？
ありません。
カッコが入れ子になってることはありますか？
ありません。
複数の括弧が存在する場合、
その種類が多種類である場合は存在します。
例：
A1:「北海道（ほかいどう）観光＜匿名＞ 温泉《おんせん》」
出力
B1: 北海道（ほかいどう）観光＜匿名＞ 温泉
C1: おんせん
.
（boruto77） 2023/07/10(月) 08:21:59
Sub test()
Dim org$, source$, mc, s1$, s2$, index&
org = [A1]
source = StrConv(org, vbWide)
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "[「（〈《〔【｛［].*?[」）〉》〕】｝］]"
Set mc = .Execute(source)
If mc.Count > 0 Then
index = mc(mc.Count - 1).FirstIndex
s1 = VBA.Mid(org, 1, index)
s2 = VBA.Mid(org, index + 1)
s2 = VBA.Mid(s2, 2, Len(s2) - 2)
[B1] = s1
[C1] = s2
End If
End With
End Sub
（まる2021） 2023/07/10(月) 09:44:50
文末のカッコで囲まれたフレーズを分割するとして下記でどうでしょう。
Sub Sample()
Const openChrs = "「（〈《〔【｛［"
Const closeChrs = "」）〉》〕】｝］"
Dim str As String
Dim openPos As Long
Dim openChr As String, closeChr As String
Dim C As Range
For Each C In Range("A1", Cells(Rows.Count, 1).End(xlUp))
str = C.Value
closeChr = Right(str, 1)
Dim Pos As Long
Pos = InStr(1, closeChrs, closeChr, vbTextCompare)
If Pos > 0 Then
openChr = Mid(openChrs, Pos, 1)
Else
C.Offset(, 1).Value = str
Exit Sub
End If
openPos = InStrRev(str, openChr, -1, vbTextCompare)
If openPos = 0 Then
C.Offset(, 1).Value = str
Exit Sub
End If
C.Offset(, 1).Value = Left(str, openPos - 1)
C.Offset(, 2).Value = Mid(str, openPos + 1, Len(str) - openPos - 1)
Next
End Sub （hatena） 2023/07/10(月) 10:07:57
まる2021さんのコード
A1と単一セル限定なので
以下のように改造してみましが[Ai]では当然エラーがでました。
org = Range(Range("A1"), Cells(LastRow, 1))でもだめです。
Sub test() Dim org$, source$, mc, s1$, s2$, index& Dim LastRow As Long Dim i As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row '最終行番号の取得
For i = 1 To LastRow
org = [Ai]
'org = Range(Range("A1"), Cells(LastRow, 1))
source = StrConv(org, vbWide)
hatenaさんのコード
A1がそのままB1に表示されてC1には何も表示されませんでした。
（boruto77） 2023/07/10(月) 10:39:41
Sub test()
Const openChrs = "「（〈《〔【｛［"
Const closeChrs = "」）〉》〕】｝］"
Dim myRange As Range, r As Range
On Error Resume Next
Set myRange = Application.InputBox( _
prompt:="対象文字列のセル範囲を選択してください。", Title:="セル選択", Type:=8)
On Error GoTo 0
If myRange Is Nothing Then Exit Sub
If myRange.Columns.Count <> 1 Then MsgBox "複数列は選択できません！", vbCritical: Exit Sub
myRange.Offset(, 1).Resize(, 2).ClearContents
Dim org$, source$, mc, s1$, s2$, index&
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "[" & StrConv(openChrs, vbWide) & "].*?[" & StrConv(closeChrs, vbWide) & "]"
For Each r In myRange
org = r.Text
source = StrConv(org, vbWide)
Set mc = .Execute(source)
If mc.Count > 0 Then
index = mc(mc.Count - 1).FirstIndex
s1 = VBA.Mid(org, 1, index)
s2 = VBA.Mid(org, index + 1)
s2 = VBA.Mid(s2, 2, Len(s2) - 2)
r.Offset(, 1) = s1
r.Offset(, 2) = s2
End If
Next
End With
End Sub
（まる2021） 2023/07/10(月) 10:57:16
投降後、コードを修正してますので、もう一度、コピーして確認してもらえますか。 当方のサンプルでは分割できてます。 （hatena） 2023/07/10(月) 10:59:59
まる2021さんのコード
只今、サンプルDATAを利用して検証中ですが、 以下のDATAのように括弧が最後出ない場合うまく出力されません
すいません。 この事例があることはを最初の質問に入れるべきでしたが 抜けていました。
A1: Jux_E (2023) [1250x45] [Code] [5.1] New
B1: Jux_E (2023) [1250x45] [Code] C1: 5.1] Ne
以下が正解
Jux_E (2023) [1250x45] [Code] New 5.1
hatenaさんのコード
最初のコードを以下に変更 openPos = InStrRev(str, openChr, -1, vbTextCompare)
只今、サンプルDATAを利用して検証中ですが、 以下のDATAのように括弧が最後出ない場合うまく出力されません
すいません。 この事例があることはを最初の質問に入れるべきでしたが 抜けていました。
A1: Jux_E (2023) [1250x45] [Code] [5.1] New
B1: Jux_E (2023) [1250x45] [Code] [5.1] New C1:
以下が正解
Jux_E (2023) [1250x45] [Code] New 5.1
（boruto77） 2023/07/10(月) 11:46:27
自分はこれで、最後の投稿とさせてもらいます。
Sub test()
Const openChrs = "「（〈《〔【｛［"
Const closeChrs = "」）〉》〕】｝］"
Dim myRange As Range, r As Range
On Error Resume Next
Set myRange = Application.InputBox( _
prompt:="対象文字列のセル範囲を選択してください。", Title:="セル選択", Type:=8)
On Error GoTo 0
If myRange Is Nothing Then Exit Sub
If myRange.Columns.Count <> 1 Then MsgBox "複数列は選択できません！", vbCritical: Exit Sub
myRange.Offset(, 1).Resize(, 2).ClearContents
Dim org$, source$, mc, s1$, s2$, index&
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "[" & StrConv(openChrs, vbWide) & "].*?[" & StrConv(closeChrs, vbWide) & "]"
For Each r In myRange
org = r.Text
source = StrConv(org, vbWide)
Set mc = .Execute(source)
If mc.Count > 0 Then
index = mc(mc.Count - 1).FirstIndex
s1 = WorksheetFunction.Replace(org, index + 1, Len(mc(mc.Count - 1)), "")
s2 = VBA.Mid(org, index + 2, Len(mc(mc.Count - 1)) - 2)
r.Offset(, 1) = s1
r.Offset(, 2) = s2
End If
Next
End With
End Sub
（まる2021） 2023/07/10(月) 12:33:25
Sub main()
Dim x As String, y As String, c1 As String, d1 As String, i As Long
x = "｢(〈《〔【{[｣)〉》〕】}]"
y = Range("A3").Value
wky = y
For i = 1 To Len(x)
wky = Replace(wky, Mid(x, i, 1), Chr(2))
wky = Replace(wky, StrConv(Mid(x, i, 1), vbWide), Chr(2))
Next i
c1 = Split(wky, Chr(2))(UBound(Split(wky, Chr(2))) - 1)
b1 = Replace(y, Mid(y, InStrRev(y, c1) - 1, Len(c1) + 2), "")
Range("B1").Value = b1: Range("C1").Value = c1
End Sub
（mm） 2023/07/10(月) 12:54:22
> 以下のDATAのように括弧が最後出ない場合うまく出力されません
下記でどうでしょう。
Sub CellSplitwithoutKTUKO()
Const openChrs = "「（〈《〔【｛［"
Const closeChrs = "」）〉》〕】｝］"
Dim str As String
Dim openPos As Long, closePos As Long
Dim C As Range
For Each C In Range("A1", Cells(Rows.Count, 1).End(xlUp))
str = C.Value
For closePos = Len(str) To 1 Step -1
If InStr(1, closeChrs, Mid(str, closePos, 1), vbTextCompare) > 0 Then
Exit For
End If
Next
For openPos = closePos - 1 To 1 Step -1
If InStr(1, openChrs, Mid(str, openPos, 1), vbTextCompare) > 0 Then
Exit For
End If
Next
If openPos > 0 And closePos > 1 Then
C.Offset(, 1).Value = Left(str, openPos - 1) & Mid(str, closePos + 1)
C.Offset(, 2).Value = Mid(str, openPos + 1, closePos - openPos - 1)
Else
C.Offset(, 1).Value = str
End If
Next
End Sub
（hatena） 2023/07/10(月) 14:59:32
まる2021さん、hatenaさんのコード
お見事です。 どちらのコードも思っている完成形で出力されました。
mmさんのコード
どうも、半角の括弧()が一組しかないDATAのみが出力されます。 （他のDATAは処理されません。）
（boruto77） 2023/07/10(月) 15:24:15
括弧がある場合は、出力されますが
括弧が無い場合、下記でエラーが出ます。
「インデックスが有効ではない」
c1 = Split(wky, Chr(2))(UBound(Split(wky, Chr(2))) - 1)
Sub main()
Dim x As String, y As String, b1 As String, c1 As String, d1 As String, i As Long
Dim c As Range
Dim wky As String
Dim count As Long
x = "｢(〈《〔【{[｣)〉》〕】}]"
count = 1
For Each c In Range("A1", Cells(Rows.count, 1).End(xlUp))
y = c.Value
wky = y
For i = 1 To Len(x)
wky = Replace(wky, Mid(x, i, 1), Chr(2))
wky = Replace(wky, StrConv(Mid(x, i, 1), vbWide), Chr(2))
Next i
c1 = Split(wky, Chr(2))(UBound(Split(wky, Chr(2))) - 1)
b1 = Replace(y, Mid(y, InStrRev(y, c1) - 1, Len(c1) + 2), "")
Cells(count, "B").Value = b1
Cells(count, "C").Value = c1
count = count + 1
Next
End Sub
（boruto77） 2023/07/10(月) 16:19:13
エラーは出なくなりましたが、ご意見有ればお願いします。
Sub main2()
Dim x As String, y As String, b1 As String, c1 As String, d1 As String, i As Long
Dim c As Range
Dim wky As String
Dim count As Long
x = "｢(〈《〔【{[｣)〉》〕】}]"
Dim r As Integer
r = MsgBox("A列にターゲットのデーターを配置していますか ？" & vbCrLf & vbCrLf & _
"「はい」で処理開始、「いいえ」で処理を終了します。", vbYesNo + vbQuestion, "データーの配置確認")
If r = vbYes Then
MsgBox "「分割と抜き出し処理」の開始", vbInformation
Else
MsgBox "処理の強制終了", vbCritical
Exit Sub
End If
count = 1
For Each c In Range("A1", Cells(Rows.count, 1).End(xlUp))
c.Offset(, 1).Resize(, 2).ClearContents
y = c.Value
wky = y
For i = 1 To Len(x)
wky = Replace(wky, Mid(x, i, 1), Chr(2))
wky = Replace(wky, StrConv(Mid(x, i, 1), vbWide), Chr(2))
Next i
If y = wky Then
Cells(count, "B").Value = " "
Cells(count, "C").Value = " "
count = count + 1
Else
c1 = Split(wky, Chr(2))(UBound(Split(wky, Chr(2))) - 1)
b1 = Replace(y, Mid(y, InStrRev(y, c1) - 1, Len(c1) + 2), "")
Cells(count, "B").Value = b1
Cells(count, "C").Value = c1
count = count + 1
End If
Next
End Sub
（boruto77） 2023/07/11(火) 08:12:15
For Each c In Range("A1", Cells(Rows.count, 1).End(xlUp))
c.Offset(, 1).Resize(, 2).ClearContents
は、
Range("A1", Cells(Rows.count, 1).End(xlUp)).Offset(, 1).Resize(, 2).ClearContents
と一度に終わらせるべき
Cells(count, "B").Value = " "
Cells(count, "C").Value = " "
は半角スペースで埋めるというのが気になる。
ClearContentsする方がいいというか、最初にClearContentsしてあるので何もする必要がない
（とおりすがり） 2023/07/11(火) 09:31:25
ClearContentsする方がいいというか、最初にClearContentsしてあるので何もする必要がない
なるほど、考えてみればそのとうりで改めて処理する必要はありませんね。
一度に終わらせるべき
なるほど、For分の中で１回毎にクリアーするのでは無く最初に１度で処理ですね。
以下に変更しました。
'B列及びC列を消去（初期化）
Range("A1", Cells(Rows.count, 1).End(xlUp)).Offset(, 1).Resize(, 2).ClearContents
For Each c In Range("A1", Cells(Rows.count, 1).End(xlUp))
y = c.Value
wky = y
勉強になります。
.
（boruto77） 2023/07/11(火) 09:50:58
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.