以前の質問のマクロ変更をお願いできますでしょうか?


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

にて質問したものです。
詳細はURLにありますが、内容を下記のようにしたいのですが、
マクロ変更をお願いできますでしょうか。

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

と、なるところ、常に1番目、2番目、3番目のインプットBOX内の選択肢に、
現在カーソルがおいてあるセルの行を固定したA,B,C列が選べるようにしてほしいのです。

例・現在、E3にカーソルがある。

商品名は?
1.A3 [A3の値表示]
2.B3 [B3の値表示]
3.C3 [C3の値表示]
4.[みかん]
5.[りんご]
6.その他→

そこでB3を選択したならば、B3の値が選択されたと判断してほしいのです。
何番目の質問でもA,B,Cが質問の1、2、3に現れるようにしてください。

お手数ですがよろしくお願いいたします。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2011/06/11 08:23:11
  • 終了:2011/06/18 08:25:03

ベストアンサー

id:TransFreeBSD No.1

TransFreeBSD回答回数662ベストアンサー獲得回数2652011/06/11 18:14:03

ポイント100pt

確認していませんが、31-32行目に挿入して以下の様にすればOKだと思います。

                selectList = Split(Replace(Mid(.Value, startDelimiterLength + 1, .Length - startDelimiterLength - stopDelimiterLength), choicesStopDelimiter, ""), choicesStartDelimiter)
                Const selCells = 3 ' 選択肢に追加する欄の数
                For i = UBound(selectList) + selCells To 1 Step -1
                    If i > selCells Then
                        selectList(i) = selectList(i - selCells)
                    Else
                        selectList(i) = ActiveSheet.Cells(ActiveCell.Row, i).Value
                    End If
                Next i
                inputboxText = selectList(0)

"Const selCells = 3"の行は最初の方に移動した方が、見た目が良いかもしれません。

あと、今気がついたのですが、変換部分が複数あった場合も毎回加えるので良いのでしょうか?

id:naranara19

大変失礼しました。ご回答に気づきませんでした。31行-32行目というのがどこにあたるのか、御手すきの時にお返事いただけたら幸いです。

誠に申し訳ありませんでした。

2011/06/18 10:17:50
  • id:TransFreeBSD
    今回の私の回答の最初の行が、前回の回答の http://q.hatena.ne.jp/1306425084#a1072637 の一番長い31行目です。
    その下の「Const 〜」から最後の行の前「Next i」までを、前回の回答の31行目の下に挿入します。
    今回の私の回答の最初の行が、前回の回答の32行目になります。
    http://q.hatena.ne.jp/1306425084#c202349 の方だと1行ずれて32〜33行目になるようです。


    やってるのは、split関数で抽出した問いと選択肢の間にA, B, Cセルの内容を3つ追加しているだけです。
  • id:TransFreeBSD
    いまさらですが間違えてました。1行追加・1行修正です。
    selectList = Split(Replace(Mid(.Value, startDelimiterLength + 1, .Length - startDelimiterLength - stopDelimiterLength), choicesStopDelimiter, ""), choicesStartDelimiter)
    Const selCells = 3 ' 選択肢に追加する欄の数
    ReDim Preserve selectList(UBound(selectList) + selCells) ' ←追加
    For i = UBound(selectList) To 1 Step -1 ' ←修正
    If i > selCells Then
    selectList(i) = selectList(i - selCells)
    Else
    selectList(i) = ActiveSheet.Cells(ActiveCell.Row, i).Value
    End If
    Next i
    inputboxText = selectList(0)
    になります。
    また、http://q.hatena.ne.jp/1306425084#c202349 に適用する場合、最後は「inputboxText」ではなく「inputTextList」に読み替えてください。
  • id:naranara19
    大変ご丁寧にありがとうございます。

    Option Explicit



    Sub 文章変換マクロ()

    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
    '挿入開始
    selectList = Split(Replace(Mid(.Value, startDelimiterLength + 1, .Length - startDelimiterLength - stopDelimiterLength), choicesStopDelimiter, ""), choicesStartDelimiter)
    Const selCells = 3 ' 選択肢に追加する欄の数
    ReDim Preserve selectList(UBound(selectList) + selCells) ' ←追加
    For i = UBound(selectList) To 1 Step -1 ' ←修正
    If i > selCells Then
    selectList(i) = selectList(i - selCells)
    Else
    selectList(i) = ActiveSheet.Cells(ActiveCell.Row, i).Value
    End If
    Next i
    inputboxText = selectList(0) '挿入終わり


    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

    ActiveCell.Value = outputText & Mid(readText, startPosition)

    End Sub

    ということでよろしいでしょうか?
    はじめの質問に回答した途端、終了してしまうものでして。
    なお、お付き合いいただいている以上、解決した際にはポイントをお支払することをお約束いたします。
  • id:TransFreeBSD
    やっぱり分かり難いですよね...
    以下になります


    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) ' 31行目
    Const selCells = 3 ' 選択肢に追加する欄の数 ←追加開始
    ReDim Preserve selectList(UBound(selectList) + selCells)
    For i = UBound(selectList) To 1 Step -1
    If i > selCells Then
    selectList(i) = selectList(i - selCells)
    Else
    selectList(i) = ActiveSheet.Cells(ActiveCell.Row, i).Value
    End If
    Next i ' ←追加終了
    inputboxText = selectList(0) ' 元32行目
    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

    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)
    Const selCells = 3 ' 選択肢に追加する欄の数
    ReDim Preserve selectList(UBound(selectList) + selCells)
    For i = UBound(selectList) To 1 Step -1
    If i > selCells Then
    selectList(i) = selectList(i - selCells)
    Else
    selectList(i) = ActiveSheet.Cells(ActiveCell.Row, i).Value
    End If
    Next i
    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

    なお、ポイントとベストアンサーをすでに頂いてます。
    私も、後で確認しようと思いつつ忘れてましたし、お気遣いは無用です。


    あと、回答時ですが目立つ緑のボタンを押すと終了しちゃうんですよ。
    あの横に目立たない返事のボタンがありまして、それだと終了しないはずです。
    緑のボタンが目立つので、思わず押しそうになるんですよね...
  • id:naranara19
    いろいろと教えていただきまして、本当にありがとうございます。
    早速書いていただいたものをやってみたのですが、

    入力できはじめるのですが、
    selectNo = Application.InputBox(Prompt:=inputboxText, Title:="数値を入力してください", Type:=1)

    のところで、「型が一致しません」のエラーがでてしまいます。
    これはどうしてでしょうか?

    またお時間のある時で十分ですので、ご教授いただければ幸いです。
  • id:TransFreeBSD
    おそらく選択肢表示の文字数がオーバーしているのだと思います。
    取り合えず、その "selectNo = 〜" を
    selectNo = InputBox(Prompt:=inputboxText, Title:="数値を入力してください")
    とすれば倍まではいけますが、これだけだと今度はキャンセルでエラーになってしまいます。
    エラーを回避するために以下の様にします。

    Dim tmp As String
    tmp = InputBox(Prompt:=inputboxText, Title:="数値を入力してください")
    If tmp = "" Then
    selectNo = 0
    Else If IsNumeric(tmp) Then
    selectNo = CLng(tmp)
    Else
    selectNo = -1
    End If

    これでひとまず選択肢の文の余裕が倍になります。それで問題ないようでしたら良いのですが、これでも足りなくなる可能性があるなら、操作方法や選択肢の表示方法なども含め、もう少し根本的に考えていく必要があるかもしれません。
  • id:naranara19
    ありがとうございます!

    Dim tmp As String
    tmp = InputBox(Prompt:=inputboxText, Title:="数値を入力してください")
    If tmp = "" Then
    selectNo = 0
    Else If IsNumeric(tmp) Then
    selectNo = CLng(tmp)
    Else
    selectNo = -1
    End If

    ↑この部分ですが、
    はじめのほうのDim i As Long, err As Long
    の次に入れればよろしいですね?

    そうすると、selectNo = InputBox(Prompt:=inputboxText, Title:="数値を入力してください")
    は替えたのですが、Else If IsNumeric(tmp) Thenが赤文字でエラーがでてしまいます。

    もしよろしければ、正しい全文を載せていただけると助かります。どこにどう挿入すればよいかピンとこないものでして。お時間のあるときで結構です。負担になられているかと思います。申し訳ありません。(強制ではございませんので)
  • id:TransFreeBSD
    こうなります。

    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) ' 31行目
    Const selCells = 3 ' 選択肢に追加する欄の数 ←追加開始
    ReDim Preserve selectList(UBound(selectList) + selCells)
    For i = UBound(selectList) To 1 Step -1
    If i > selCells Then
    selectList(i) = selectList(i - selCells)
    Else
    selectList(i) = ActiveSheet.Cells(ActiveCell.Row, i).Value
    End If
    Next i ' ←追加終了
    inputboxText = selectList(0) ' 元32行目
    selectListVount = UBound(selectList)
    For i = 1 To UBound(selectList)
    inputboxText = inputboxText & vbCrLf & i & " : " & selectList(i)
    Next i
    inputboxText = inputboxText & vbCrLf & i & " : その他を手入力"

    err = 3: 'エラー上限
    Do
    Dim tmp As String
    tmp = InputBox(Prompt:=inputboxText, Title:="数値を入力してください")
    If tmp = "" Then
    selectNo = False
    ElseIf IsNumeric(tmp) Then
    selectNo = CLng(tmp)
    Else
    selectNo = -1
    End If
    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

    ActiveCell.Value = outputText & Mid(readText, startPosition)
    ' MsgBox outputText & Mid(readText, startPosition)
    End Sub
  • id:naranara19
    このたびは長々とお付き合いいただき、本当にありがとうございます。

    完璧に動きました。

    TransFreeBSDさんの、誠実なお人柄とお仕事能力の高さに深く感謝します。

    ポイントもプレゼントさせてください。

    本当にありがとうございました。
  • id:TransFreeBSD
    お気遣いありがとうございます。
    ありがたく頂いておきます。
  • id:naranara19
    わざわざありがとうございます。今後ともよろしくお願い申し上げます。

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

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

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

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