Application.InputBoxで疑問

質問

アクティブセルの文字列を求めるVBAのコードをお願いします。

マクロを実行した後で、処理するセルを選択したいので
下記コードを利用するとします。

Sub Sample1()
Dim Target As Range
Set Target = Application.InputBox("セルを選択してください", Type:=8)
End Sub

例えば、
sheet2の２行目列の61列目(BJ)から65列目(BN)までをアクティブセルに指定したとして
(Sheet2のrange("BJ2:BN2")相当）

前提として
検索する文字列は、1セルに1文字ずつしか記入されていません。

下記の場合では、
BJ BK BL BM BN
2 R a n g e

上記の場合は、Rangeが求める文字列です。

Targetで求めるアドレスは最初の「$BJ$2」だけで
必要な文字列としては
Selection.Addressで「$BJ$2:$BN$2」です。

どう変換すれば良いのか良く判りません。

回答No.15

kkkkkm · ベストアンサー

それ以降に「同じ箇所」があった場合に連続技を利用するのに
MsgBoxの YesNoCancelの三択を利用したらいかがでしょう。確認と問い合わせを一度のMsgBoxで処理します。

'どこにあるか？表示し、実行動作確認
YesNoCancel = MsgBox(n - 1 & "/" & Total & " : " & str & vbLf _
& vbLf _
& F_Num & "文字目から" & vbLf _
& E_Num & "文字目まで" & vbLf & vbLf _
& "以降変名は、全て同じ箇所ですか？", vbYesNoCancel + vbQuestion, "問い合わせ")

'アクティブ色を元に戻す (黒色)
Target.Font.Color = vbBlack

If YesNoCancel = vbCancel Then
Exit Sub
End If

Ws1.Activate

If YesNoCancel = vbYes Then
For nn = n To Ws1.Cells(Rows.Count, 1).End(xlUp).Row
Ws1.Cells(nn, "B") = Left(str, F_Num - 1) & Mid(str, E_Num + 1)
Next

回答No.14

kkkkkm

> msgBoxで「はい、」「いいえ」で処理を選択し
> 違った場合、「いいえ」を選択して”処理中止”の表示でEXit Subで終了のような事だと思いますが？

はい、"変名は、全て同じ箇所ですか"のところと同じ感じでvbNoならEXit Sub的な。

あと

If Flag = "Different each time" Then GoTo JampTo 'YesNoは1回だけ判断
は
If Flag <> "Different each time" Then
で
JampTo:
を
End If
でいいのではないでしょうか。
ただ、同じ箇所じゃないとした場合、それ以降に「同じ箇所」があった場合に連続技ができないことになります。

> 実際ws1.のB列に変名予定が上手く書き込めているかが分からないことです。

Ws2.Activate
Set Target = Application.InputBox("セルを選択してください", Type:=8)

中略

Ws1.Activate
Ws1.Cells(n, "B") = Left(str, F_Num - 1) & Mid(str, E_Num + 1)
Flag = "Different each time"
MsgBox "確認"

としてみてください。

お礼

kkkkkmさん、助言を頂き全て思うような処理が出来ました。

もう少し改造したいとの欲が出ていますが、
一晩考えてどうするか？思考したいと思います。

今回も解決できて嬉しいです。
改めてお礼申し上げます。

回答No.13

kkkkkm

mlen = Len(str1)
instrNum = InStr(str, str1)

だと同じ文字列があった場合に先に出現する文字列を変換すると思います。
(確認の時に違う値が出るので変名前にわかりますが)

折角、重複しても大丈夫なように
Left(str, instrNum - 1) & Mid(str, instrNum + mlen)
としたのですし

InputBoxで選択するのですから選択したセル範囲の最初と最後の1行目の値を取得したほうがいいのではないでしょうか。

前略

F_Num = Target.Item(1).Offset(-1, 0).Value
E_Num = Target(Target.Columns.Count).Offset(-1, 0).Value
'どこにあるか？表示する
MsgBox str & vbLf _
& vbLf _
& F_Num & "文字目から" & vbLf _
& E_Num & "文字目まで"

中略
↓vbNoの時だけのコードなのでvbYesの時も変更してください。
Ws1.Cells(n, "B") = Left(str, F_Num - 1) & Mid(str, E_Num + 1)

としておけば選択した部分だけがなくなると思います。

あと
'どこにあるか？表示する
の時に違うなと思って×で閉じた場合は先に進まないようにしたほうがいいのではないでしょうか。

お礼

>mlen = Len(str1)
>instrNum = InStr(str, str1)
>だと同じ文字列があった場合に先に出現する文字列を変換すると思います。

そうでした。
せっかく、前に指摘されて変更したので同じ仕様にした方が間違いないですね。

よくよく考えると
YesNo = MsgBox("変名は、全て同じ箇所ですか？", Buttons:=vbYesNo, Title:="問い合わせ")
の問い合わせは、1度チェックすれば2回め以降は必要ないので
1回だけ問い合わせるように以下のように仕様変更しました。
一番簡単なGoto文で分岐させました。

If Flag = "Different each time" Then GoTo JampTo 'YesNoは1回だけ判断
YesNo = MsgBox("変名は、全て同じ箇所ですか？", Buttons:=vbYesNo, Title:="問い合わせ")

If YesNo = vbYes Then
For nn = 2 To Ws1.Cells(Rows.Count, 1).End(xlUp).Row
' Ws1.Cells(nn, "B") = Left(str, instrNum - 1) & Mid(str, instrNum + mlen)
Ws1.Cells(n, "B") = Left(str, F_Num - 1) & Mid(str, E_Num + 1)
Next
'セルの内容に合わせて列幅を自動調整する
Ws1.Range("A:B").EntireColumn.AutoFit
MsgBox "変名が終了しました。（処理文字は全て同じ箇所です。)"
Exit Sub
Else
End If

JampTo:
'Ws1に新ファイル名候補を書き出す
' Ws1.Cells(n, "B") = Left(str, instrNum - 1) & Mid(str, instrNum + mlen)
Ws1.Cells(n, "B") = Left(str, F_Num - 1) & Mid(str, E_Num + 1)
Flag = "Different each time"
Next

又、何行目を処理しているか分かるように以下のように処理番号（例：1/6）を付加しました。

'処理番号及びどこにあるか？表示する
MsgBox n - 1 & "/" & Total & " : " & str & vbLf _
& vbLf _
& F_Num & "文字目から" & vbLf _
& E_Num & "文字目まで"

>どこにあるか？表示する
>の時に違うなと思って×で閉じた場合は先に進まないようにしたほうがいいのではないでしょうか。

msgBoxで「はい、」「いいえ」で処理を選択し
違った場合、「いいえ」を選択して”処理中止”の表示でEXit Subで終了のような事だと思いますが？
どうでしょうか？

今ひとつ、不満点が有るとすれば
YesNo = MsgBox("変名は、全て同じ箇所ですか？", Buttons:=vbYesNo, Title:="問い合わせ")　
でvbNoを選択してDATA数だけ変名の為Inputで処理する文字を選択し
上記の「'処理番号及びどこにあるか？表示する」処理でOKをクリックすると
連続して「'処理番号及びどこにあるか？表示する」処理の表示が出るので
実際ws1.のB列に変名予定が上手く書き込めているかが分からないことです。
ws2からws1にシートを切り替えるとInputBoxの記入部に自動的にシート名が表示されるので
確認が取れても以後の処理に不具合が出ます。

回答No.12

kkkkkm

> 以上が経緯ですが、ご理解願えたでしょうか？

はい、悪くない方法だと思います。

>（2重手間となる作業セルでマス目分割、ナンバリングなどを別途作成するなど必要ない事だと）

そういう事ではありませんので、説明の方法でいいのだと思います。

> やりたかったことはこの１分に着きます。

どちらにしても、解決したようで良かったです。

お礼

最後までお付き合い願いありがとうございました。

私の説明が不十分や頓珍漢な補足が有り
要らぬお手数を掛けましたが
何とか先が見えてきたと思いました。

後は、w1シート"DATA"のA列に有る複数の変名候補を
For n = 2 To Ws1.Cells(Rows.Count, 1).End(xlUp).Rowで
必要数繰り返すだけと思い以下のようにコードを修正しましたが

ターゲットの文字列が以下だとして
ハセガワ Hasegawa 10842 川崎 EC-1 “電子戦訓練機” [1/72 ウォーバードコレクション

n=1の１ループ目は、上手く表示されるのですが
n=2になると
InputBoxで「EC-1」をカーソルで選択して
上手く選択文字が赤色で表示されていますが

実際は、「instrNum」 が24文字目で
「instrNum + mlen - 1」 が27文字目のはずが

EXCELは、「instrNum」 が0文字目で
「instrNum + mlen - 1」 が5文字目と表示します。

この為、
以下で「プロシージャの呼び出し、または引数が不正です。」のエラーが出ます
'Ws1に新ファイル名候補を書き出す
Ws1.Cells(n, "B") = Left(str, instrNum - 1) & Mid(str, instrNum + mlen)

ループ2回めで上手く処理できない原因は何でしょうか？
（解決策を教えて下さい。）

Sub ファイル名変換_InputBox版_改訂版()

Dim str As String
Dim i As Long
Dim n As Long
Dim nn As Long
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim MojiSuu As Integer

Dim str1 As String
Dim instrNum As Long
Dim mlen As Integer
Dim ii As Long
Dim Target As Range

Dim YesNo As VbMsgBoxResult

Set Ws1 = Worksheets("DATA")
Set Ws2 = Worksheets("変名補助(文字列は何処に)")

For n = 2 To Ws1.Cells(Rows.Count, 1).End(xlUp).Row
'書き出しセル初期化
Ws2.Range("A1:zz2").ClearContents

'ターゲットファイル名及び文字数
str = Ws1.Cells(n, "A")
MojiSuu = Len(str)

Ws2.Activate

'マス目を作成してターゲットファイル名を書き出す

For i = 1 To MojiSuu
'Numbering（1-）の記入
Ws2.Cells(1, i) = i

'Numberの書式
Ws2.Cells(2, i).ColumnWidth = 2
Ws2.Cells(i, i).HorizontalAlignment = xlCenter
Ws2.Cells(1, i).Font.Size = 7

'一文字ずつ文字記入(1-MojiSuu)
Ws2.Range("A2").Offset(0, i - 1).Value = Mid(str, i, 1)

'記入文字の書式
Ws2.Cells(2, i).ColumnWidth = 2
Ws2.Cells(2, i).HorizontalAlignment = xlCenter
Ws2.Cells(1, i).Font.Size = 7
Next

On Error Resume Next 'InpuBoxでキャンセルを選択した場合の処理(1) (2)とセットで仕様

Set Target = Application.InputBox("セルを選択してください", Type:=8)

'InpuBoxでキャンセルを選択した場合の処理 (2)
If Target Is Nothing Then
Exit Sub
End If
On Error GoTo 0

'InputBoxでアクティブセルのサーチする文字列を取得
For ii = 1 To Target.Columns.Count
str1 = str1 & Target.Item(ii)
Next

'InputBoxで指定した文字列を着色する
Target.Font.Color = vbRed

'サーチ文字(InputBox指定）位置とその表示
mlen = Len(str1)
instrNum = InStr(str, str1)

'どこにあるか？表示する
MsgBox str & vbLf _
& vbLf _
& instrNum & "文字目から" & vbLf _
& instrNum + mlen - 1 & "文字目まで"

'アクティブ色を元に戻す (黒色)
Target.Font.Color = vbBlack

Ws1.Activate

YesNo = MsgBox("変名は、全て同じ箇所ですか？", Buttons:=vbYesNo, Title:="問い合わせ")

If YesNo = vbYes Then
For nn = 2 To Ws1.Cells(Rows.Count, 1).End(xlUp).Row
Ws1.Cells(nn, "B") = Left(str, instrNum - 1) & Mid(str, instrNum + mlen)
Next
'セルの内容に合わせて列幅を自動調整する
Ws1.Range("A:B").EntireColumn.AutoFit
MsgBox "変名が終了しました。（処理文字は全て同じ箇所です。)"
Exit Sub
Else
End If

'Ws1に新ファイル名候補を書き出す
Ws1.Cells(n, "B") = Left(str, instrNum - 1) & Mid(str, instrNum + mlen)

Next

'セルの内容に合わせて列幅を自動調整する
Ws1.Range("A:B").EntireColumn.AutoFit

MsgBox "変名が終了しました。"

End Sub

補足

自己解決しました。

For分の最初に「str1 = ""」として
リセットしないとstr1にループ毎に
文字列が付加されてしまっていました。

For n = 2 To Ws1.Cells(Rows.Count, 1).End(xlUp).Row
'書き出しセル初期化
Ws2.Range("A1:zz2").ClearContents
str1 = ""

回答No.11

kkkkkm

> >どこをアクティブセルだと考えているのかよく分かりません。
>
> 以下でカーソルで選択している箇所です。
> Set Target = Application.InputBox("セルを選択してください", Type:=8)

> 検索対象は、strです。
> ws1.Range("A2")の文字列を
> ws2.Range("A2").Offset(0, i - 1).Value = Mid(str, i, 1)　で
> ws2.Range("A2")から１文字ずつ右方向へすべて書き出しています。

検索対象とアクティブセルが何故違うのでしょう。

元の考え方
poss = InStr(str, str1)
If poss > 0 Then
With ActiveCell.Characters(Start:=poss, Length:=Len(str1)).Font
.Color = vbRed
End With
End If
は、それぞれ
str = ws1.Range("A2")
ss = str
ActiveCell.Value = ss
ですから
ws1.Range("A2")のデータの中にInputBoxで選択して生成した文字列があるかどうかを判別し、あればその文字を赤くしたいという考え方で、ws1.Range("A2")のデータをActiveCellに代入してそのセルの文字色を変化させようとしています。
この場合、検索対象とアクティブセルは同じです。

で、アクティブセル(ActiveCell)がInputBoxで選択したセル範囲というのはおかしくないですか？

No.9にも書きましたが
InputBoxで選択したセル範囲を着色したいのでしたら
Stopの前に
Target.Font.Color = vbRed

お礼

理解できないのは私の説明の仕方が、悪いのが原因でお手数をおかけしています。

>検索対象とアクティブセルが何故違うのでしょう。

長くなりますが経緯を説明したいと思います。

元の検査（サーチ）対象は、ws1.Range("A2")の文字列
例えば、
以下が「A2」の１セルに入っています。（例も長い文字列ですが実際はもっと長い文字列です。）
ハセガワ Hasegawa 10842 川崎 EC-1 “電子戦訓練機” [F012256234-B4563256-G85623-HJ524126_1/72 ウォーバードコレクション]

この文字列から、必要ない一部の文字列を除いた（修正した）文字列をws1.Range”B2"に書き込みたいと思っています。
つまり変名が目的です。
例えでは「F012256234-B4563256-G85623-HJ524126_」の部分を除いた
ハセガワ Hasegawa 10842 川崎 EC-1 “電子戦訓練機” [1/72 ウォーバードコレクション]をws1.Range”B2"に書き込みたい。

変名するには、
「F012256234-B4563256-G85623-HJ524126_」が
元の文字列の「どこから-何処まで」に配置されているか調べる必要があり
「A2」文字列が長いので一文字ずつ前から数えていては間違いも多く現実的ではありません。

なので思いついたのが以下の手順です
１）この文字列をws2.Range("A2")以下に作業セルにマス目は作成して1文字ずつ全て書き出す
例では、1文字ずつ「川崎　-----　コレクション]では「A2-CN2」までの92文字
補助の目的でws2.Range("A１")から右側に同じくマス目を作成してナンバー（01-92）を配置する

２）ws2.Range("A2")から右側を対象に
肉眼で不要部分を確認してInputBoｘで不要部分をカーソルで選択指定
一文字ずつ区切っているのでws1.Range("A2")の文字列から先頭から数えるよりは簡単に位置が指定できる。

例の場合は「F012256234-B4563256-G85623-HJ524126_」をカーソルで指定

３）その配置位置をEXCELで求めさせる
（例では、「F012256234-B4563256-G85623-HJ524126_」は、
先頭から39番目から74番めまでが相当　--＞　セル範囲では＝AM2-BV2）

４）配置位置が求められたので別のマクロで変名を行う作業を行う

機能的にはInputBoxで選択した部分の色付け＝「アクティブセルを着色」は必要ないのですが
２）で選択したのを確認の意味で行いたいと思った訳です。

以上が経緯ですが、ご理解願えたでしょうか？
VBAの達人さんは、もっとスマートな方法を採用されると思いますが
素人の私が思いついた案なので納得できない部分があると思います。

一晩考慮してようやく理解できました。

kkkkkmさんは直接、
最初のws1.Range("A2")の文字列でInpuBoxでなぜ位置を求めないのかと言われていると思いますが
（2重手間となる作業セルでマス目分割、ナンバリングなどを別途作成するなど必要ない事だと）
kkkkkmさんの構想は、恥ずかしながら私は全く考慮しませんでした。
先の1)-4)の構想有りきで考えて柔軟性が無かったと思っています。

今一度、構想を変えて設計し直しを考えたいと思っています。

補足

N0.10の回答について

>以下のようなことでもないと思いますが…

前略-攻略　の間のコードでは、
マクロが開始される前にws2シートのいずれかにカーソルがあったセルに
ws1.range("A2")が表示されてInputBoxで指定した文字が着色されています。

着色したいのは、マクロ開始後A2より右側のInputBoxで選択された部分のセルです。

No.9の回答について

>Stopの前に
> Target.Font.Color = vbRed

そうです。
やりたかったことはこの１分に着きます。

回答No.10

kkkkkm

以下のようなことでもないと思いますが…

前略
ws2.Activate

Set Target = Application.InputBox("セルを選択してください", Type:=8)

'InputBoxでアクティブセルのサーチする文字列を取得
For ii = 1 To Target.Columns.Count
str1 = str1 & Target.Item(ii)
Next

'アクティブセルを着色
Dim poss As Integer
Dim ss As String
ss = str
ActiveCell.Value = ss
poss = InStr(str, str1)
If poss > 0 Then
With ActiveCell.Characters(Start:=poss, Length:=Len(str1)).Font
.Color = vbRed
End With
End If
後略

回答No.9

kkkkkm

> 'アクティブセルを着色

どこをアクティブセルだと考えているのかよく分かりません。

> str ----> サーチ元の文字列
ですので
> str = ws1.Range("A2")
なのですが
No.6のお礼の時点では
> ss = str
> ActiveCell.Value = ss
になっていたでしょうから ActiveCellがどこだと考えていたのか分かりません。

$BJ$2:$BN$2
を着色したいのでしたら
Stopの前に
Target.Font.Color = vbRed

ですが
> poss ---> サーチ元の文字列中の"BASKET"の先頭からの順番
> ”B"は38番目で間違いない数値です。

なのでそうでもなさそうですし。

どこのセルを検索対象としたいのでしょう。

補足

説明が良くないので解決が遅れてすいません。

>どこをアクティブセルだと考えているのかよく分かりません。

以下でカーソルで選択している箇所です。
Set Target = Application.InputBox("セルを選択してください", Type:=8)

17：04のお礼の中にある「BASKET」でセル番地では
　　AL2、AM2，AN2，A02，Ap2　の５文字です。

>どこのセルを検索対象としたいのでしょう。

検索対象は、strです。
ws1.Range("A2")の文字列を
ws2.Range("A2").Offset(0, i - 1).Value = Mid(str, i, 1)　で
ws2.Range("A2")から１文字ずつ右方向へすべて書き出しています。

回答No.8

kkkkkm

> InputBoxで指定したセルを対象

だと$BJ$2:$BN$2の範囲のセルが対象になります、なので
> Each C------>Tatgetで指定した文字列の”BASKET"が１文字単位
でしたら
で、C.Charactersは1文字です。

「InputBoxで指定したセルの値を結合した文字列」ですね。

もとのご自身のコードで
ActiveCell
を実際のセルSheets("Sheet1").Range("A1")等に変更してください。

もとのstrがstr1になっているのに今気が付きました。

補足

>もとのご自身のコードで
>ActiveCell
>を実際のセルSheets("Sheet1").Range("A1")等に変更してください。

現在のコードには、「ActiveCell」のコードはありません。
以下に現在のコードを不要と思われる箇所を除いて掲載します。

’----------------------　以下現在のコード

'ターゲットはマクロ起動後に後から選択
Sub 文字列は何処に_inputbox()

Dim str As String
Dim i As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim MojiSuu As Integer

Set ws1 = Worksheets("DATA")
Set ws2 = Worksheets("変名補助(文字列は何処に)")

'書き出しセル初期化
ws2.Range("A1:zz2").ClearContents

'ターゲットファイル名及び文字数
str = ws1.Range("A2")
MojiSuu = Len(str)

'マス目を作成してターゲットファイル名を書き出す
For i = 1 To MojiSuu
'Numbering（1-）の記入
ws2.Cells(1, i) = i

'Numberの書式
ws2.Cells(2, i).ColumnWidth = 2
ws2.Cells(i, i).HorizontalAlignment = xlCenter
ws2.Cells(1, i).Font.Size = 7

'一文字ずつ文字記入(1-MojiSuu)
ws2.Range("A2").Offset(0, i - 1).Value = Mid(str, i, 1)

'記入文字の書式
ws2.Cells(2, i).ColumnWidth = 2
ws2.Cells(2, i).HorizontalAlignment = xlCenter
ws2.Cells(1, i).Font.Size = 7
Next

Dim str1 As String
Dim instrNum As Long
Dim mlen As Integer
Dim ii As Long
Dim Target As Range

Set Target = Application.InputBox("セルを選択してください", Type:=8)

'InputBoxでアクティブセルのサーチする文字列を取得
For ii = 1 To Target.Columns.Count
str1 = str1 & Target.Item(ii)
Next

Stop

'アクティブセルを着色
Dim poss As Integer
Dim C As Range

For Each C In Target
poss = InStr(str, str1)
If poss > 0 Then
With C.Characters(Start:=poss, Length:=Len(str1)).Font
.Color = vbRed
End With
End If
Next

mlen = Len(str1)
instrNum = InStr(str, str1)

MsgBox ”確認が終了したら、セルの着色を元に戻して終了します。"

'アクティブ色を元に戻す (黒色)
For Each C In Target
poss = InStr(str, str1)
If poss > 0 Then
With C.Characters(Start:=poss, Length:=Len(str1)).Font
.Color = vbBlack
End With
End If
Next

End Sub

回答No.7

kkkkkm

> No5，6の回答については、この問題が解決して取り掛かりますので
> 　　少しお待ち下さい。

No5，6は、今回の問題としては間違っていた回答が冗長であった事への訂正ですので、多少気に留めていただく程度でいいと思います。

> マクロ中にInputBoxで指定したセルを対象にしたいのですが

$BJ$2:$BN$2を対象にするのに

ss = str
ActiveCell.Value = ss
や
ActiveCell.Characters

の理由がよく分かりませんが、色付けするコードは同じコードの中にあるのでしたら
Dim c As Range
For Each c In Target
poss = InStr(str, str1)
If poss > 0 Then
With c.Characters(Start:=poss, Length:=Len(str1)).Font
.Color = vbRed
End With
End If
Next

お礼

修正コードありがとうございます。

>ss = str
> ActiveCell.Value = ss
>の理由がよく分かりませんが

Strを保持したかったのでそのように書きましたが
必要ないコードかも知れません。

>色付けするコードは同じコードの中にあるのでしたら

はい。同じ標準モジュールの同じSub()の中にあります。

以下の修正いただいたコードをそのまま利用しました。

不思議ですが
　エラー無く処理されますが、文字に色が全く付きません。

F8でトレースしながら数値や文字列を確認しても以下のように問題ないように思えます。

以後、例として”BASKET"を指定したとして
Each C------>Tatgetで指定した文字列の”BASKET"が１文字単位
”B","A","S","K","E","T"
str ----> サーチ元の文字列
str1 ---> Targetで指定した文字列 ”BASKET"
poss ---> サーチ元の文字列中の"BASKET"の先頭からの順番
”B"は38番目で間違いない数値です。
Len(str1) ---> Targetの文字数　"BASKET"だから5で間違いないい数値です。

'-------------- 現在のコード
'アクティブセルを着色

Dim poss As Single
Dim C As Range

For Each C In Target
poss = InStr(str, str1)
If poss > 0 Then
With C.Characters(Start:=poss, Length:=Len(str1)).Font
.Color = vbRed
End With
End If
Next

回答No.6

kkkkkm

No.5

Range(Target.Address).Value
は
Target.Value
でした。

お礼

kkkkkmさん、No4のアドバイスを受けて下記コードで上手く処理できました。

（No5，6の回答については、この問題が解決して取り掛かりますので
　　少しお待ち下さい。）

Set Target = Application.InputBox("セルを選択してください", Type:=8)

'InputBoxでアクティブセルのサーチする文字列を取得
For ii = 1 To Target.Columns.Count
str1 = str1 & Target.Item(ii)
Next

ついでにアクテイブセルを目立つように赤色に着色したかったので
下記のコードを想定しましたが
マクロを開始する前にシート上でアクティブに成っていたセルに結果が表示されてしまいました。

マクロ中にInputBoxで指定したセルを対象にしたいのですが
どう改造すれば良いでしょうか　？
（最後に着色を戻すコードも追加しています。）

'アクティブセルを着色
Dim poss As Single
Dim ss As String

ss = str
ActiveCell.Value = ss
poss = InStr(str, str1)
If poss > 0 Then
With ActiveCell.Characters(Start:=poss, Length:=Len(str1)).Font
.Color = vbRed
End With
End If

'アクティブ色を元に戻す (黒色)
With ActiveCell.Characters(Start:=poss, Length:=Len(str1)).Font
.Color = vbBlack
End With

回答No.5

kkkkkm

今回は関係しませんが、No.3までの回答の訂正です

Range("BC3").Resize(1, Target.Count).Value = Target.Item(1).Resize(1, Target.Count).Value
は
↓一行対応の場合
Range("BC3").Resize(1, Target.Columns.Count).Value = Range(Target.Address).Value
↓複数行対応の場合
Range("BC3").Resize(Target.Rows.Count, Target.Columns.Count).Value = Range(Target.Address).Value

で良かった。右辺が冗長でした。。
一度Range(Target.Address).Valueでテストしたときにエラーだったので使えないと思ってたのですが、その後他の事をやっているときには使えたので、テストの時に何か勘違いしてたのだと思います。