エクセルのセル内の文字列操作マクロをお願いします。


エクセルのあるセルに、全角分で5000字程度の説明文があります。

例・これは■■商品名は?[みかん][りんご]□□です。送料は■■送料は?[500][800][1000]□□です。

そのセルにカーソルをおいてマクロをかけると、インプットBOXで
商品名は?
[みかん]
[りんご]
その他→

と、カッコ内にあるものが順番に並び、選べる様にして下さい。選んだら次の選択にうつります。該当しなければ、その他のボックス内に言葉を入力できるとします。キャンセルボタンもお願いします。

完成・これはみかんです。送料は800円です。

となるようにしてほしいのです。

■■が文字列変換の合図で、■■に次ぐ文字が選択肢の見出し、□□がその欄の終わりの合図としたいのです。[]はできるだけ多く対応してくれると嬉しいです。

よろしくお願いいたします。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2011/05/27 00:51:27
  • 終了:2011/05/31 06:37:55

ベストアンサー

id:windofjuly No.1

うぃんど回答回数2625ベストアンサー獲得回数11492011/05/27 04:44:47

ポイント70pt

この部の「コメント・トラックバックを表示する」にチェックが入っていないため細かな点を相談できず、直接作って見ました

 

選択と入力のどちらでも1回で操作できるようにしようとすればフォームを作らなければならず面倒ですし、その結果、思惑と違うと言われると立つ瀬もなくなるので、今回は文字列の切り出しを焦点と捕らえることとし選択はInputBoxのみで行えるようにしてあります(そのため、その他を入力するには1ステップ余分にかかります)

結果をどこに書き出すか不明のため、とりあえずmsgboxで出力してます

Option Explicit

Sub Macro1()
    Const startDelimiter = "■■"
    Const stopDelimiter = "□□"
    Const choicesStartDelimiter = "["
    Const choicesStopDelimiter = "]"

    Dim readText As String, outputText As String
    Dim startDelimiterLength As Long, stopDelimiterLength As Long, startPosition As Long
    Dim selectList() As String, selectListVount As Long, inputboxText As String, selectNo As Long, inputStr As String
    Dim regExp As Object, regExpMatches, regExpMatche
    Dim i As Long, err As Long
    
    startDelimiterLength = Len(startDelimiter)
    stopDelimiterLength = Len(stopDelimiter)
    startPosition = 1
    
    readText = ActiveCell.Value
    outputText = ""
    
    Set regExp = CreateObject("VBScript.RegExp")
    With regExp
        .pattern = startDelimiter & ".+?" & stopDelimiter
        .IgnoreCase = True
        .Global = True
        Set regExpMatches = .Execute(readText)
        Debug.Print outputText
        For Each regExpMatche In regExpMatches
            With regExpMatche
                selectList = Split(Replace(Mid(.Value, startDelimiterLength + 1, .Length - startDelimiterLength - stopDelimiterLength), choicesStopDelimiter, ""), choicesStartDelimiter)
                inputboxText = selectList(0)
                selectListVount = UBound(selectList)
                For i = 1 To UBound(selectList)
                    inputboxText = inputboxText & vbCrLf & i & " : " & selectList(i)
                Next i
                inputboxText = inputboxText & vbCrLf & i & " : その他を手入力"

                err = 3: 'エラー上限
                Do
                    selectNo = Application.InputBox(Prompt:=inputboxText, Title:="数値を入力してください", Type:=1)
                    If selectNo = False Then Exit Sub
                    If selectNo > 0 And selectNo <= UBound(selectList) Then
                        outputText = outputText & Mid(readText, startPosition, .FirstIndex - startPosition + 1) & selectList(selectNo)
                        startPosition = .FirstIndex + .Length + 1
                        Exit Do
                    ElseIf selectNo = UBound(selectList) + 1 Then
                        inputStr = Application.InputBox(Prompt:=selectList(0), Title:="数値/文字を入力してください", Type:=2)
                        If inputStr = "False" Then Exit Sub
                        outputText = outputText & Mid(readText, startPosition, .FirstIndex - startPosition + 1) & inputStr
                        startPosition = .FirstIndex + .Length + 1
                        Exit Do
                    Else
                        err = err - 1
                        If err = 0 Then MsgBox "エラー回数上限を超えましたのでマクロは停止します": Exit Sub
                    End If
                Loop
            End With
        Next
    End With

    MsgBox outputText & Mid(readText, startPosition)
End Sub
id:naranara19

すごくうれしいご回答に感謝します。

この部の「コメント・トラックバックを表示する」にチェックが入っていないため細かな点を相談できず、直接作って見ました

↑すみませんでした。よく理解しておりませんでした。


その他を手入力で1ステップとありますが、それで十分です。ご配慮ありがとうございます。

【お願い1】

最後、コメント表示の処理ありがとうございます。ではなく、一度コメント欄にこれで登録しますか?とした時に、OK、キャンセル(一切初めにも戻る)を選べ、その同じセルに上書きという形でお願いできますでしょうか?

【お願い2】

また、コメント欄にすると、5000字もあり、最後のみの表示で全体を確認できませんので、もう少し欄が大きくすることはできますでしょうか?

しかし、思い通りの感じでしっかりと動いてくれて、嬉しいです。

お手数ですが、お時間がすいたときによろしくお願いします。丁寧にマクロをくんでいただいて心より感謝いたします。

2011/05/27 12:12:26

その他の回答(1件)

id:windofjuly No.1

うぃんど回答回数2625ベストアンサー獲得回数11492011/05/27 04:44:47ここでベストアンサー

ポイント70pt

この部の「コメント・トラックバックを表示する」にチェックが入っていないため細かな点を相談できず、直接作って見ました

 

選択と入力のどちらでも1回で操作できるようにしようとすればフォームを作らなければならず面倒ですし、その結果、思惑と違うと言われると立つ瀬もなくなるので、今回は文字列の切り出しを焦点と捕らえることとし選択はInputBoxのみで行えるようにしてあります(そのため、その他を入力するには1ステップ余分にかかります)

結果をどこに書き出すか不明のため、とりあえずmsgboxで出力してます

Option Explicit

Sub Macro1()
    Const startDelimiter = "■■"
    Const stopDelimiter = "□□"
    Const choicesStartDelimiter = "["
    Const choicesStopDelimiter = "]"

    Dim readText As String, outputText As String
    Dim startDelimiterLength As Long, stopDelimiterLength As Long, startPosition As Long
    Dim selectList() As String, selectListVount As Long, inputboxText As String, selectNo As Long, inputStr As String
    Dim regExp As Object, regExpMatches, regExpMatche
    Dim i As Long, err As Long
    
    startDelimiterLength = Len(startDelimiter)
    stopDelimiterLength = Len(stopDelimiter)
    startPosition = 1
    
    readText = ActiveCell.Value
    outputText = ""
    
    Set regExp = CreateObject("VBScript.RegExp")
    With regExp
        .pattern = startDelimiter & ".+?" & stopDelimiter
        .IgnoreCase = True
        .Global = True
        Set regExpMatches = .Execute(readText)
        Debug.Print outputText
        For Each regExpMatche In regExpMatches
            With regExpMatche
                selectList = Split(Replace(Mid(.Value, startDelimiterLength + 1, .Length - startDelimiterLength - stopDelimiterLength), choicesStopDelimiter, ""), choicesStartDelimiter)
                inputboxText = selectList(0)
                selectListVount = UBound(selectList)
                For i = 1 To UBound(selectList)
                    inputboxText = inputboxText & vbCrLf & i & " : " & selectList(i)
                Next i
                inputboxText = inputboxText & vbCrLf & i & " : その他を手入力"

                err = 3: 'エラー上限
                Do
                    selectNo = Application.InputBox(Prompt:=inputboxText, Title:="数値を入力してください", Type:=1)
                    If selectNo = False Then Exit Sub
                    If selectNo > 0 And selectNo <= UBound(selectList) Then
                        outputText = outputText & Mid(readText, startPosition, .FirstIndex - startPosition + 1) & selectList(selectNo)
                        startPosition = .FirstIndex + .Length + 1
                        Exit Do
                    ElseIf selectNo = UBound(selectList) + 1 Then
                        inputStr = Application.InputBox(Prompt:=selectList(0), Title:="数値/文字を入力してください", Type:=2)
                        If inputStr = "False" Then Exit Sub
                        outputText = outputText & Mid(readText, startPosition, .FirstIndex - startPosition + 1) & inputStr
                        startPosition = .FirstIndex + .Length + 1
                        Exit Do
                    Else
                        err = err - 1
                        If err = 0 Then MsgBox "エラー回数上限を超えましたのでマクロは停止します": Exit Sub
                    End If
                Loop
            End With
        Next
    End With

    MsgBox outputText & Mid(readText, startPosition)
End Sub
id:naranara19

すごくうれしいご回答に感謝します。

この部の「コメント・トラックバックを表示する」にチェックが入っていないため細かな点を相談できず、直接作って見ました

↑すみませんでした。よく理解しておりませんでした。


その他を手入力で1ステップとありますが、それで十分です。ご配慮ありがとうございます。

【お願い1】

最後、コメント表示の処理ありがとうございます。ではなく、一度コメント欄にこれで登録しますか?とした時に、OK、キャンセル(一切初めにも戻る)を選べ、その同じセルに上書きという形でお願いできますでしょうか?

【お願い2】

また、コメント欄にすると、5000字もあり、最後のみの表示で全体を確認できませんので、もう少し欄が大きくすることはできますでしょうか?

しかし、思い通りの感じでしっかりと動いてくれて、嬉しいです。

お手数ですが、お時間がすいたときによろしくお願いします。丁寧にマクロをくんでいただいて心より感謝いたします。

2011/05/27 12:12:26
id:kumi54 No.2

kumi54回答回数32ベストアンサー獲得回数02011/05/29 10:27:56

ポイント10pt

http://home.att.ne.jp/zeta/gen/excel/c04p39.htm

↑ここに載っていますでしょうか。

id:naranara19

ありがとうございます!参考にはなるのですが、マクロをお願いしたいのです。あまり集まりすぎてもいけないので、件数はしぼっていますが、ポイントは良い回答にはしっかりと上乗せしております。

2011/05/29 21:30:02
  • id:windofjuly
    うぃんど 2011/05/27 16:56:24
    【1】一度コメント欄にこれで登録しますか?とした時に、OK、キャンセル(一切初めにも戻る)を選べ、その同じセルに上書きという形
     
    改造しましたが、もうひとつの問題点がまだあるので投稿は控えてます
    (今のところ、処理手順を若干変更するだけで済んでます)
     
    【2】コメント欄にすると、5000字
     
    InputBoxのPromptにて表示できる上限は半角で1024文字なので十分ではないかと考えていたのですが
    ■■商品名は?[みかん][りんご]□□の部分を抜き出した結果がそれをはるかに上回るということですか?
     
    はるかに上回る場合はInputBoxを複数回表示するか、あるいはフォームやシートを使うか
    あるいはまったく別の手段(Excelから逸脱していくのでお勧めはできないけれど、何事もやってやれないことは無いということで)…
     
    文字数制限ではなくて、行数が問題なだけということでしたら 
    1行1選択肢ではなく
     1 : みかん
     2 : りんご
     ・・・
     n : パイナップル
     n+1 : もも
    1行複数選択肢という形にすることでなんとかできそうですですが、実際の文字数はどの程度に?
     1 : みかん、2 : りんご・・・
     n : パイナップル、n+1 : もも・・・

     
    【3】
    上の話は上の話として、ここからは別の話になりますが、
    同じセルを上書きするということから「定型文から選び出す」という処理を繰り返すのだと思いました
    「5000字程度の説明文」という定型文が常に同じ(あるいは、あまり変更されない)のだとすれば
    それを例えばSheet2に一覧の形に抜き出してしまったほうが楽ではないでしょうか?
     
    マクロとしては次の2つになります
    (a)Sheet2のA1に「5000字程度の説明文」を入れておけば、それをSheet2全体に展開してくれるマクロ
      このマクロは定型文が変わった場合にのみ起動させる(変更時に自動的に起動させることも可能)
    (b)このマクロを起動すると、Sheet2に切り替わり、その中で順にクリックしていけば1つの文にまとめてくれるマクロ
     
    毎度毎度InputBoxで処理するよりも、直感的に操作できるのではないかと思いますがいかが?
    仮に「5000字程度の説明文」が複数種類ある場合でもSheetが増えるだけでマクロそのものは2つで済ませられます
    (マクロを起動するときに、どのシートを使うのかをパラメータとして渡すようにします)
  • id:naranara19
    ありがとうございます!

    【2】コメント欄にすると、5000字

    ・セル内の総文字数はHTMLの商品説明のため、枠などがかなり字数がかかり5000文字くらいいってしまいます。
    それでは、インプットBOX複数回でOKを押していく形でお願いできますでしょうか?


    ・各選択肢は1回のインプットボックスで1024文字以内で十分に収まりそうです。
    (選択肢は最大でも20個くらいですし、それほど長いものではありません)



    【3】「5000字程度の説明文」という定型文が常に同じ(あるいは、あまり変更されない)のだとすれば
    それを例えばSheet2に一覧の形に抜き出してしまったほうが楽ではないでしょうか?

    ありがとうございます。これは結構異なる場合がありまして、そのために仕様のような形でお願いしております。

    また、シートは1つでないと困ることがありまして、ご提案はとても嬉しいのですが、今回は上記のように
    お願いできますでしょうか?

    これだけ親切に言っていただくことはあまりなく、大変うれしく思っております。
    本当にありがとうございます。
  • id:windofjuly
    うぃんど 2011/06/01 05:45:06
    月末進行ならびに妙案が浮かばなかったので回答できませんでした
    申し訳ないです

    いまだ、これといった妙案は浮かんでいないのですが、
    最初のコメントで書いたコードだけ残しておきたいと思います

    >|vb|
    Option Explicit

    Sub Macro2()
    Const startDelimiter = "■■"
    Const stopDelimiter = "□□"
    Const choicesStartDelimiter = "["
    Const choicesStopDelimiter = "]"

    Dim targetCell As Range
    Dim outputText As String
    Dim startDelimiterLength As Long, stopDelimiterLength As Long, startPosition As Long
    Dim selectList() As String, inputTextList As String, inputText As Long
    Dim regExp As Object, regExpMatches, regExpMatche
    Dim i As Long, err As Long

    startDelimiterLength = Len(startDelimiter)
    stopDelimiterLength = Len(stopDelimiter)

    Set targetCell = ActiveCell

    Set regExp = CreateObject("VBScript.RegExp")
    With regExp
    .pattern = startDelimiter & ".+?" & stopDelimiter
    .IgnoreCase = True
    .Global = True
    Set regExpMatches = .Execute(targetCell.Value)
    Do
    outputText = ""
    startPosition = 1
    For Each regExpMatche In regExpMatches
    With regExpMatche
    selectList = Split(Replace(Mid(.Value, startDelimiterLength + 1, .Length - startDelimiterLength - stopDelimiterLength), choicesStopDelimiter, ""), choicesStartDelimiter)
    inputTextList = selectList(0)
    For i = 1 To UBound(selectList)
    inputTextList = inputTextList & vbLf & i & " : " & selectList(i)
    Next i
    inputTextList = inputTextList & vbLf & i & " : その他を手入力"

    err = 3: 'エラー上限
    Do
    inputText = Application.InputBox(Prompt:=inputTextList, Title:="数値を入力してください", Type:=1)
    If VarType(inputText) = vbBoolean Then Exit Sub
    If inputText > 0 And inputText <= UBound(selectList) Then
    outputText = outputText & Mid(targetCell.Value, startPosition, .FirstIndex - startPosition + 1) & selectList(inputText)
    startPosition = .FirstIndex + .Length + 1
    Exit Do
    ElseIf inputText = UBound(selectList) + 1 Then
    inputText = Application.InputBox(Prompt:=selectList(0), Title:="数値/文字を入力してください", Type:=2)
    If VarType(inputText) = vbBoolean Then Exit Sub
    outputText = outputText & Mid(targetCell.Value, startPosition, .FirstIndex - startPosition + 1) & inputText
    startPosition = .FirstIndex + .Length + 1
    Exit Do
    Else
    err = err - 1
    If err = 0 Then MsgBox "エラー回数上限を超えましたのでマクロは停止します": Exit Sub
    End If
    Loop
    End With
    Next
    outputText = outputText & Mid(targetCell.Value, startPosition)
    Select Case MsgBox(outputText & vbCrLf & "これで登録しますか?" & vbCrLf & "「いいえ」で選択に戻ります「キャンセル」で作業中止します", vbYesNoCancel, "登録確認")
    Case vbYes
    targetCell.Value = outputText
    Exit Sub
    Case vbNo
    ' 何もしないことによってDoに戻る
    Case Else
    Exit Sub
    End Select
    Loop
    End With
    End Sub
    ||<
     
    これくらいしか案が浮かんでないのですが・・・
    下記の行にて強制的に文字数制限(例えば頭100文字)してしまう
    変更前 inputTextList = inputTextList & vbLf & i & " : " & selectList(i)
    変更後 inputTextList = inputTextList & vbLf & i & ":" & left(selectList(i),100)
  • id:naranara19
    十分でした。月末のお忙しい中、せかしてしまったようでまことに申し訳ありませんでした。ご協力に大変感謝しております。改造していただいたもので、ばっちり対応できております。本当にありがとうございました。御身体にご自愛くださいませ。また何かありましたらぜひご協力をお願い申し上げます。(マクロを作っていただくことが多いのです)
  • id:naranara19
    windofjulyさん、その節はお世話になりました。本質問の少し変更を別スレでお願いしましたので、よろしければご回答願えますでしょうか?

    http://q.hatena.ne.jp/1307748190

    それとその他欄を選ぶよりやはり、1回目の際にその他もそのまま入力できると作業しやすかったです。もしよろしければ、そのあたりも変更いただけるとありがたいです。

    お時間のあるときにお願いできたら幸いです。(義務に感じないでくださいませ。もしよろしければお願いします。しっかりポイントお支払いたします)

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません