こんなマクロを作っていただけないでしょうか（願）。

質問

エクセルです。
Ａ列に、すでに文章が入力済みです。

　　　　　　　　　　　　　Ａ　　　　　　　　　　　　Ｂ　　　　Ｃ
１　｜こんな操作ができたら最高です。｜　　　｜　　　　｜

Ａ１の「操作」のみを選択し、マクロを実行する。
　　↓
Ａ１は変更なし。
Ｂ１に「操作」部分のみを、その文字数×２倍の全角空白に変更，下線をつける。
Ｃ１に「操作」と出力。

この例で言うならば、
Ｂ１は２文字（操作）×２＝４文字分の全角空白に変え、下線をつける。

イメージとしては、

　　　　　　　　　　　　Ａ　　　　　　　　　　　　　　　　　　　　Ｂ　　　　　　　　　　　　　　　Ｃ
１　｜こんな操作ができたら最高です。｜こんな○○○○ができたら最高です。｜操作｜

※　○○は空白で、この空白に下線を引けたら最高です。

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

回答No.6

imogasi · ベストアンサー

#3のものです。ご丁寧にご返事頂き恐縮します。
「動かなかった」との事ですが、
ＯＫ－ＷＥＢに載った時、横（行）の文字の制限数の関連で、原文１行の文字数が多いと、強制的に改行されてしまうケースがあります。＃３の例では
（１）Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)は元は１行です。
（２）Cells(i, 2) = Mid(TextBox1, 1, s) & String(l + 2, "＿") & Mid(TextBox1, s + l + 1, Ln - (s + n)) も１行です。
（３）Private Sub Worksheet_SelectionChange(ByVal Target As Range) も１行です。
●各行の右端にカーソルを置きＤＥＬキーを適当数押すと
そしてそれを行数回行うと、ＶＢＥ画面上で１行になります。
会社の仲間の方が、してくださったことはそれだと思います。やって見てください。宜しく。

お礼

度々ありがとうございました。
私がこの仕事に復帰できたときには、すでに作成したかったエクセルが完成しており、作っていただいたマクロ使用できるようになっておりました。
本当にありがとうございました。

※５日に締め切ると申しておきながら、風邪をひきまして遅くなりました。
　みなさんのお力添えをいただき、無事解決できました。
　ありがとうございました。

回答No.5

nishishi

NO1です。
条件がわかったので作り直しました。
1行目からＡ列に文字がなくなるまで繰り返すように
しました。
漢字はすべて抜き出しして、空白に置き換えます。

Excel 2000 のマクロで漢字の含まれているセルを検索する方法
ということで下記ＵＲＬにあります。

Sub kanji_nuki()
Do While Len(Cells(ActiveCell.Row, 1)) > 0
Cells(ActiveCell.Row, 3).Activate
Call CheckKanji(Cells(ActiveCell.Row, 1))
Call Underline(Cells(ActiveCell.Row, 2))
ActiveCell.Offset(1, 0).Activate
Loop
End Sub
Private Sub CheckKanji(Str As String)
Dim tempChr As String '調べる文字
Dim tempStr As String
Dim tempCode As Integer '調べる文字のコード
Dim i As Long 'ループカウンタ
Dim StartCode As Integer '最初の漢字のコード
Dim EndCode As Integer '最後の漢字のコード
Dim col_no As Integer '列ナンバー

Const StartChr As String = "亜" '最初の漢字
Const EndChr As String = "黑" '最後の漢字

'漢字をコードに変換
StartCode = Asc(StartChr)
EndCode = Asc(EndChr)

col_no = 3
For i = 1 To Len(Str)
tempStr = Mid(Str, i, 1)
tempCode = Asc(tempStr)
'判定
Select Case tempCode
Case StartCode To EndCode '漢字の場合
Cells(ActiveCell.Row, col_no) = _
　　　　　　　　　　Cells(ActiveCell.Row, col_no) & tempStr
tempStr = "　　"
Case Else '漢字以外
If Len(Cells(ActiveCell.Row, 3)) > 0 Then
col_no = col_no + 1 '列番号に１足す
End If
End Select
Cells(ActiveCell.Row, 2) = Cells(ActiveCell.Row, 2) & tempStr
Next i

End Sub
Private Sub Underline(Str As String)
Dim i As Integer 'ループカウンタ
Dim tempStr As String '調べる文字
For i = 1 To Len(Str)
tempStr = Mid(Str, i, 1)
If tempStr = "　" Then
Cells(ActiveCell.Row, 2). _
Characters(Start:=i, Length:=1).Font.Underline _
= xlUnderlineStyleSingle
End If
Next i
End Sub

参考URL：

http://oshiete1.goo.ne.jp/kotaeru.php3?q=330592

お礼

度々すみませんでした。
お手数をお掛けいたしました。
本当に、私の説明不足で申し訳なかったのですが、「漢字を全て」という操作ではありませんでした。
ただ、社員が「はぁ～、なるほどねぇ・・・」と言いながら作業をしておりましたので、何かヒントをいただけたのだと思います。
今は別の仕事に追われている私も、２,３日するとこちらの仕事に戻れると思うので、そうしたら早速試してみます。
今回は本当にありがとうございました。
また機会があったら、よろしくお願いいたします。

※１０月５日に締め切らせていただきます。
　みなさん、本当にありがとうございました。

回答No.4

nishi6

Sheet1で実行する例です。セルを部分的に選択するためにテキストボックスを使ってみます。

Sheet1にコマンドボタン１個とテキストボックス１個を配置します。
コントロール名はCommandButton1とTextBox1です。
これは、表示→ツールバー→コントロールツールボックスのコマンドボタンとテキストボックスです。

マクロを１回実行すれば、ボタンとテキストボックスは非表示になります。
コントロール名、プロパティ等は特に変えません。ボタンのCaptionは自由に設定して下さい。
ボタンは小さく、テキストボックスは横に細長くしたほうがいいでしょう。

変更したいセルを選択して、マクロ『Okikae』を実行すると、そのセルの下にコマンドボタンとセルの内容を表示したテキストボックスが表示されます。
この状態で、テキストボックスのテキストから変更したい文字を選択してボタンを押します。
これで、質問の処理が行われるはずです。(Excel97で確認)
(文字が入っているセルを１つ選択して実行するようにして下さい。)

既にセルにアンダーラインが設定してある場合、解除されないようにするのに行数を要しています。
マクロ『Okikae』はショトカットキーを設定しておくと操作性もあがると思います。　　ご参考に。

Sheet1のコードウインドウに貼り付け（OkikaeとCommandButton1_Click）
↓
'ボタンとテキストボックスを表示。置き換える文字を選択する
Sub Okikae()
　　'ボタンとテキストボックスをセルの下に表示する
　　With ActiveCell
　　　　CommandButton1.Left = .Left
　　　　CommandButton1.Top = .Offset(1, 0).Top
　　　　CommandButton1.Visible = True
　　　　TextBox1.Left = .Left + CommandButton1.Width
　　　　TextBox1.Top = CommandButton1.Top
　　　　TextBox1.Visible = True
　　　　TextBox1.Text = ActiveCell
　　End With
End Sub

'選択した文字を全角空白に置き換える
Private Sub CommandButton1_Click()
　　Dim SelText As String '選択テキスト
　　Dim iSrt As Integer 'テキスト選択位置
　　Dim iLgh As Integer '選択テキストの長さ
　　Dim L As Integer '文字カウンタ
　　Dim id As Integer '処理前の文字位置
　　Dim udLn() 'アンダーライン情報

　　With TextBox1
　　　　iSrt = .SelStart
　　　　iLgh = .SelLength

　　　　'選択文字のみ抽出
　　　　SelText = Mid(.Text, iSrt + 1, iLgh)
　　　　ActiveCell.Offset(0, 2) = SelText

　　　　'処理前のアンダーラインの状況を保持する
　　　　ReDim udLn(Len(.Text) + iLgh)
　　　　For L = 1 To Len(.Text)
　　　　　　If L < iSrt + 1 Then
　　　　　　　　id = L
　　　　　　ElseIf iSrt + iLgh < L Then '選択箇所より後ろはずらす
　　　　　　　　id = L + iLgh
　　　　　　End If
　　　　　　udLn(id) = ActiveCell.Characters(L, 1).Font.Underline
　　　　Next

　　　　'選択文字を全角空白にしてアンダーラインを引く
　　　　SelText = Left(.Text, iSrt) & String(iLgh * 2, "　") & Right(.Text, Len(.Text) - iSrt - iLgh)

　　　　ActiveCell.Offset(0, 1) = SelText
　　　　ActiveCell.Offset(0, 1).Activate
　　　　With ActiveCell
　　　　　　For L = 1 To Len(.Text)
　　　　　　　　If iSrt + 1 <= L And L <= (iSrt + iLgh * 2) Then
　　　　　　　　　　.Characters(L, 1).Font.Underline = xlUnderlineStyleSingle
　　　　　　　　Else
　　　　　　　　　　'処理前のアンダーライン情報を復元する
　　　　　　　　　　.Characters(L, 1).Font.Underline = udLn(L)
　　　　　　　　End If
　　　　　　Next
　　　　End With

　　　　'ボタンとテキストボックスを非表示する
　　　　CommandButton1.Visible = False
　　　　.Text = ""
　　　　.Visible = False
　　　　ActiveCell.Offset(0, -1).Select
　　End With
End Sub

お礼

私とは初めてですが、実はnishi6様には、当社の別の社員がお世話になったことがございます。
その節は、本当に素晴らしい技術をご提案いただきありがとうございました。
そして、今回も素晴らしい技術をご提供いただき、本当にありがとうございます。
私のほうは、別の仕事が入ってしまい、まだその技術を試しておりませんが、
社員いわく、「お～、さすがだー。」と絶叫しておりましたので、うまく行ったのだと思います。
私も、明後日にでもさっそくご提案いただいた技術を試して見たいと思っております。
本当にありがとうございました。
また機会がありましたら、よろしくお願いいたします。

回答No.3

imogasi

誰よりも短く、よりＶＢＡらしく、操作の手数を少なくをめざしました。
＜操作要領＞
（１）Ａ列の各行に文字列（原文）を入れる。
（２）Ａ列の行をクリックすると、そのセルの文字列が一旦テキストボックスにセットされます。
（３）テキストボックスの文字列の一部の（続いた）文字を
マウスでなぞりマウスをＵｐする。範囲指定のような調子。
（４）するとテキストボックスの文字列の一部の、なぞった文字だけが文字＿に置き換わって同じ行のＢ列に自動的にセットされます。
取り急ぎで色々なテスト不足ですがよろしく。Ｃｅｌｌの
ＳｅｌＳｔａｒｔ等が使えればもっとすっきりするのですが、締め切られそうで急いで入れます。
終わったら、ＶＢのツールバー△定規と鉛筆のアイコンをへこまして終わってください。
Public i As Integer

Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
s = TextBox1.SelStart
l = TextBox1.SelLength
Ln = Len(TextBox1.Value)
Cells(i, 2) = Mid(TextBox1, 1, s) & String(l + 2, "＿") & Mid(TextBox1, s + l + 1, Ln - (s + n))
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
TextBox1.Text = Target.Value
i = Target.Row
End Sub

お礼

じ、実は・・・。
私が試したところ、うまく操作してくれませんで、会社の仲間に見せました。
で、どこか少々直した（本当か？）ようで、それでうまく作動してくれたそうです。
私のほうは別の仕事が入ってしまい、まだその素晴らしい技術を拝見しておりません（スミマセンヌ）。
明後日にでも、必ず・・・。
本当にありがとうございました。
また機会があったら、よろしくお願いいたします！

補足

※お一人お一人のご回答を試しておりますので、〆切＆お礼はもう少し時間がかかりそうです。
締め切るときは、ご連絡致します。（ex.３日後に、など）

では、これからやってみます・・・。

回答No.2

Enfant

こんにちは

「出来ないと思います。」

「Ａ１の「操作」のみを選択し、」の時、A1のセルが編集状態になり、それが確定状態にならないと関数もマクロも動かないと思います。

そこで、代案ですが
B1には自分で入力する。（コピペするなどして）
C1に「=LEFT(A1,FIND(B1,A1)-1)&REPT("　",LEN(B1)*2)&MID(A1,FIND(B1,A1)+LEN(B1),50)」
とする。
でどうでしょうか。

お礼

数式も、便利なときありますよね。
ご提案の数式を拝見して、まだまだ勉強不足だなって思いました。
今回はありがとうございました。

回答No.1

nishishi

こんなんで、どうでしょう？
ただし、処理できるのが１行目だけで、操作という
文字にしか対応できてません。
連続処理する条件とか対象の文字とかもう少し詳しく
おしえていただけると、ある程度対応できると思います。
基本的な考え方としては
・文字列の操作は関数で行い値に変換しています。

Sub Macro1()
'
Range("C1").Select
ActiveCell.FormulaR1C1 = "操作"

Range("B1").Select
ActiveCell.FormulaR1C1 = "=FIND(RC[1],RC[-1])"
chara_start = ActiveCell
ActiveCell.FormulaR1C1 = "=LEN(RC[1])"
chara_length = ActiveCell * 2

ActiveCell.FormulaR1C1 = "=SUBSTITUTE(RC[-1],RC[1],REPT(""　""," & chara_length & "))" 'LEN(RC[1])*2
ActiveCell.Value = ActiveCell.Value

With ActiveCell.Characters(Start:=chara_start, Length:=chara_length).Font
.Name = "ＭＳ Ｐゴシック"
.FontStyle = "標準"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleSingle
.ColorIndex = xlAutomatic
End With
Range("B2").Select
End Sub

お礼

すいません、本当に無知なもので、どう答えたら良いものか・・・。
Ａ列には文章がいくつも入力されています。
ですから、Ａ１だけではなく、Ａ２，Ａ３・・・と続けて処理ができると助かります。
現在１２０件近くの入力がありますが、今後、増える予定があります。
それと、対象の文字列ですが、これは本当に指定のしようがないです。
単語もしくは文節になる、としか申し上げようがございません。
例えば、「こんな操作ができたら最高です。」についても、本当は「操作」と「最高」の二つを指定したいのです。
ですが、２箇所って、選択できませんでしたよね？確か。
それで、１回目に「操作」を処理し、２回目に「最高」を処理させようかなと考えたのでした。

やりたいこととしましては、穴埋め問題の作成と考えていただけるとイメージしていただけるのではないかと思います。

またお時間がありましたら、よろしくお願いいたします。
今回は、ありがとうございました。