Results of 1 - 1 of about 85 for VBA 強制終了 (0.004 sec.)
vba (14722), 強制終了 (237)
- [[20230710054939]]
- #score: 16177
- @digest: 0715a843632ee43668955547f982f7c8
- @id: 94657
- @mdate: 2023-07-11T00:50:58Z
- @size: 14931
- @type: text/plain
- #keywords: openpos (142097), closepos (80122), wky (63503), boruto77 (60967), closechrs (59046), openchrs (59046), 1250x45 (46493), openchr (29993), parenthesis (28021), 観光 (18421), vbwide (10665), vbtextcompare (9107), myrange (8514), instrrev (7965), ッコ (7682), source (7519), 括弧 (7036), mc (6604), strconv (6513), firstindex (6303), 匿名 (5340), org (5281), str (5084), カッ (4775), （bo (4086), 2023 (3314), lastrow (3066), hatena (2912), replace (2900), 北海 (2626), 海道 (2563), count (2407)
- 『括弧内の文字列を抜き出す』（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 ---- mmさんのコードを手直してみました。 括弧がある場合は、出力されますが 括弧が無い場合、下記でエラーが出ます。 「インデックスが有効ではない」 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 ---- mmさんのコードをお借りして エラーが出なくなるよう幼稚なコードを追加してみました。 エラーは出なくなりましたが、ご意見有ればお願いします。 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 ---- ＞エラーは出なくなりましたが、 だったらそれでいいじゃん。 （???） 2023/07/11(火) 09:02:25 ---- ＞ご意見有ればお願いします。 ということなので 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分の中で1回毎にクリアーするのでは無く最初に1度で処理ですね。 以下に変更しました。 '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... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/202307/20230710054939.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97018 documents and 608145 words.
訪問者：