• 締切済み

VBA　書式設定を保持したままセル内の文字を追記

EXCEL2010で医療系マクロを作っています。 CheckBox1は、Selection.Offset(0, -1)のセル内の文字を取消線にする為のチェックボックスです。 TextBox11は、Selection.Offset(0, -1)のセル内の文字の下に追記する為のテキストボックスです。 ～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～ If CheckBox1 = True Then ' ' '取消線がある場合 Selection.Offset(0, -1).Characters(InStr(Selection.Offset(0, -1), vbLf), 1000).Font.Strikethrough = True Selection.Offset(0, -1).Value = Selection.Offset(0, -1).Value + vbLf + TextBox11.Value ' ' '☆追記して改行以降を取消し追記を解除 Else ' ' '取消線がない場合 Selection.Offset(0, -1).Value = Selection.Offset(0, -1).Value + vbLf + TextBox11.Value ' ' '☆追記 End If ～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～ この場合、Selection.Offset(0, -1)の文字にすでに取消線が設定されている場合にそれが外れたり、元々ついていなかったのについたりします。 書式設定を保持したままセル内の文字を追記することは可能でしょうか？ 何卒ご教示のほどよろしくお願いします。

みんなの回答

回答No.1

Excel2007でしか試していませんが、 次のようにすると元々入っていたテキストの書式設定を維持して テキストを追加できるようです。 追加したテキストの書式は、元のテキストの末尾の書式と同じになります。 '------------------------------------------------------------------- Sub sample() 　　Dim srcLen As Integer '元の文字列の長さ 　　Dim tgtCell As Range '対象セル 　　Set tgtCell = Selection.Offset(0, -1) 　　srcLen = Len(tgtCell.FormulaR1C1) 　　tgtCell.Characters(srcLen + 1).Insert (vbLf & "あああ") '末尾にテキストを追加 End Sub

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. オフィス系ソフト

関連するQ&A

  • 【EXCEL2010 VBA】　部分的書式設定

    初心者ながら医療業務用マクロを作っています。 テキストボックス内の１行目のみ取消線を解除する方法を教えてください。 UserForm1.TextBox12.Lines(1).Font.Strikethrough = False これではさすがにエラーが出ました； 何卒よろしくお願いします。

  • エクセル VBAのチェックボックスについて

    お読みくださり、ありがとうございます。 エクセル初心者でございます。 エクセルのマクロなのですが、 お詳しい方、是非教えて欲しいです！汗 調子に乗って入力フォームなるものを作りました。 入力フォームの中にて、チェックボックスで「ある」「なし」の項目を入れてみたのですが、チェックしていないのに、値が入る現象が起きています汗 以下、素人が書いたコードを恥を承知で記載させていただきます。 Private Sub CheckBox1_Click() If CheckBox1.Value = True Then OK = "○" End If End Sub Private Sub CheckBox2_Click() If CheckBox2.Value = True Then NO = "×" End If End Sub Private Sub UserForm_Click() End Sub '以下のコードは、登録ボタンがクリックされたときの処理！ Private Sub 登録ボタン_Click() If TextBox1.Text = "" Then MsgBox "グッズ名を入力してください。" Exit Sub End If If TextBox2.Text = "" Then MsgBox "アプローチ先を入力してください。" Exit Sub End If With Worksheets("協賛グッズ") With Cells(Rows.Count, 2).End(xlUp) .Offset(1, 0).Value = TextBox1.Text .Offset(1, 1).Value = mori .Offset(1, 2).Value = mori2 .Offset(1, 3).Value = TextBox2.Text .Offset(1, 5).Value = TextBox3.Text .Offset(1, 6).Value = TextBox4.Text .Offset(1, 7).Value = TextBox5.Text .Offset(1, 8).Value = TextBox6.Text End With End With TextBox1.Text = "" TextBox2.Text = "" TextBox3.Text = "" TextBox4.Text = "" TextBox5.Text = "" TextBox6.Text = "" CheckBox1.Value = False CheckBox2.Value = False End Sub 以上です。 おかしなところ満載かと思いますが、 チェックを入れた項目だけ値を入れたいと考えております。 おわかりになるかたおりましたら何卒お助けください汗 よろしくお願いいたします。

  • Excel VBA 文字列の一部の取り消し線の判別

    ExcelのVBAでセルの中の文字列の一部に 取り消し線があるかどうかを知るにはどのように記述すればよいでしょうか。 例えば、A1セルの中にAAA,BBB,CCCと入力されていて BBBにだけ文字飾りの取り消し線が設定されているような場合、 以下のコードではELSEになってしまいます。 If ThisWorkbook.Sheets("Sheet1").Range("A1").Font.Strikethrough = True Then MsgBox ("このセルには取り消し線があります") Else MsgBox ("このセルには取り消し線はありません") End If

  • VBAを始めたばかりなので初歩的な質問なのですが、

    VBAを始めたばかりなので初歩的な質問なのですが、 Private Sub CmdBtn1_Click() On Error GoTo err1 Dim TxtBx1 As String Dim TxtBx2 As Long TxtBx1 = TextBox1 TxtBx2 = TextBox2 Range("a65535").End(xlUp).Offset(1).Select '新しいセルにデータを追加 Selection = Selection.Row - 2 Selection.Offset(, 1).Value = TxtBx1 Selection.Offset(, 2).Value = ComboBox1 Selection.Offset(, 3).Value = TxtBx2 ---------------省略--------------- '「取消」ボタンのオン If Len("A3") > 0 Then CmdBtn2.Enabled = True End If '初期化 TxtBx1 = "" TxtBx2 = "" ComboBox1.ListIndex = -1 Call TxtBx1.SetFocus Exit Sub 実行すると、初期化のところで変数(Txtbx1,TxtBx2)などが反転して、 「修飾子が不正です」と出ます。 変数を使わないで直接指定すると問題無いみたいなのですがよくわかりません。 こんな質問ですいませんが宜しくお願いします。

  • 処理速度を速くする方法教えてください。

    Private Sub CommandButton1_Click() Dim irow As Long Dim Celldata(1 To 6) As Double Dim ekimen(1 To 6) As String '高さ読込み If TextBox8.Value = "" Then MsgBox ("No.を入力") End End If If TextBox9.Value = "" Then MsgBox ("温度を入力") End End If If TextBox10.Value = "" Then MsgBox ("係数を入力") End End If Celldata(1) = TextBox1.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value Celldata(2) = TextBox2.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value Celldata(3) = TextBox3.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value Celldata(4) = TextBox4.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value Celldata(5) = TextBox5.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value Celldata(6) = TextBox6.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value '入力と修正 Dim i As Long '最終行から試験Noが一致するものを探す For i = 65535 To 6 Step -1 If CStr(Cells(i, 1)) = Trim(TextBox8.Value) Then Set myrange = Sheets("データ").Cells(i - 1, 1) '記入セルがoffset(1,x)になっているため、i-1にしています。 Exit For End If Next i 'Noが一致しない場合、最終行を記入セルに設定する。 If i = 5 Then Set myrange = Sheets("データ").Range("A65536").End(xlUp) End If 'ワークシートへの転記 With myrange .Offset(1, 0).Value = TextBox8.Value '----No. .Offset(1, 1).Value = Celldata(1) '----１計測 .Offset(1, 2).Value = Celldata(2) '----２計測 .Offset(1, 3).Value = Celldata(3) '----３ル計測 .Offset(1, 4).Value = Celldata(4) '----４計測 .Offset(1, 5).Value = Celldata(5) '----５計測 .Offset(1, 6).Value = Celldata(6) '----６計測 .Offset(1, 13).Value = TextBox1.Value '----１追加 .Offset(1, 14).Value = TextBox2.Value '----２追加 .Offset(1, 15).Value = TextBox3.Value '----３追加 .Offset(1, 16).Value = TextBox4.Value '----４追加 .Offset(1, 17).Value = TextBox5.Value '----５追加 .Offset(1, 18).Value = TextBox6.Value '----６追加 .Offset(1, 19).Value = TextBox7.Value '---温度 .Offset(1, 20).Value = TextBox11.Value '----１高さ .Offset(1, 21).Value = TextBox12.Value '----２高さ .Offset(1, 22).Value = TextBox13.Value '----３高さ .Offset(1, 23).Value = TextBox14.Value '----４高さ .Offset(1, 24).Value = TextBox15.Value '----５高さ .Offset(1, 25).Value = TextBox16.Value '----６高さ '入力ボックスのクリア TextBox1.Value = "" '----1セル TextBox2.Value = "" '----2セル TextBox3.Value = "" '----3セル TextBox4.Value = "" '----4セル TextBox5.Value = "" '----5セル TextBox6.Value = "" '----6セル TextBox7.Value = "" '---温度 TextBox11.Value = "" '----1セル TextBox12.Value = "" '----2セル TextBox13.Value = "" '----3セル TextBox14.Value = "" '----4セル TextBox15.Value = "" '----5セル TextBox16.Value = "" '----6セル End With 'lblComment.Caption = "ワークシートに転記しました！" End Sub Private Sub CommandButton2_Click() Dim i As Long '入力チェック If TextBox8.Value = "" Then MsgBox ("No.を入力") End End If If TextBox9.Value = "" Then MsgBox ("温度を入力") End End If If TextBox10.Value = "" Then MsgBox ("係数を入力") End End If For i = 65535 To 6 Step -1 If CStr(Cells(i, 1)) = Trim(TextBox8.Value) Then Set myrange = Sheets("データ").Cells(i - 1, 1) '記入セルがoffset(1,x)になっているため、i-1にしています。 Exit For End If Next i '受付No.がない場合、終了します。 If i = 5 Then MsgBox ("No.が見つかりません") End End If '入力の処理と逆の処理を行います。 With myrange TextBox1.Value = .Offset(1, 13).Value '---１計測 TextBox2.Value = .Offset(1, 14).Value '---２計測 TextBox3.Value = .Offset(1, 15).Value '---３計測 TextBox4.Value = .Offset(1, 16).Value '---４計測 TextBox5.Value = .Offset(1, 17).Value '---５計測 TextBox6.Value = .Offset(1, 18).Value '---６計測 TextBox7.Value = .Offset(1, 19).Value '---温度 TextBox11.Value = .Offset(1, 20).Value '---１高さ TextBox12.Value = .Offset(1, 21).Value '---２高さ TextBox13.Value = .Offset(1, 22).Value '---３高さ TextBox14.Value = .Offset(1, 23).Value '---４高さ TextBox15.Value = .Offset(1, 24).Value '---５高さ TextBox16.Value = .Offset(1, 25).Value '---６高さ End With End Sub

  • 空白セルと０値を識別させたい。（VBA）

    すみません、誰か教えていただけますか。 シートの53、54、55行目にそれぞれ値入っています。 それを３行目にビジュアル的に表現させています。 55行目はセルの色で、53行目は数値があり同じ値が 続く部分の合計を出しています。 しかし、下記の記述ですと数値が0（変数D=0）の時に うまくいきません。空白セルと認識されてしまうと思います。 何か、良い方法があれば教えて頂けませんでしょうか。 宜しくお願いします。 Sub 表示() Dim a As Long Dim c As Long Dim D As Long Dim e As String Dim f As String c = 3 For a = 3 To 64 With Worksheets("Sheet1") If .Cells(53, a) <> .Cells(53, a + 1) Then .Range(.Cells(53, c), .Cells(53, a)).Select D = WorksheetFunction.Sum(Selection) e = D f = Selection(1).Offset(1, 0).Value G = Selection(1).Offset(2, 0).Value If D <> 0 Then Selection(1).Offset(-50, 0).Value = f + "//" + e .Range(.Cells(53, c), .Cells(53, a)).Offset(-50, 0).Select Selection.Interior.ColorIndex = G End If If Selection(1).Value = "" Then .Range(.Cells(53, c), .Cells(53, a)).Offset(-50, 0).Select Selection.ClearContents Selection.Interior.ColorIndex = xlNone End If c = a + 1 End If End With Next End Sub

  • CheckBoxとTextBoxの値を貼付る方法

    よろしくお願いします。 Dim n As Long Dim r As Range Dim C, buf As String n = Cells(Rows.Count, "A").End(xlUp).Row + 1 Range("A" & n).Select For Each C In Controls If TypeName(C) = "CheckBox" Then If C.Value Then buf = buf & C.Caption & vbCrLf End If Next C ActiveCell.Offset(-1, 16).Value = buf & TextBox9.Value ’buf＝チェックされている複数のCheckBoxのCaption ’この時のActiveCell.Offset(-1, 16).ValueにはbufとTextBox9の値も表示されています。 End If で、セルに入力して ActiveCell.Offset(0, 7).Value = ActiveCell.Offset(-1, 16).Value で、セルに貼り付けようとすると、bufの値のみ表示されてTextBox9の値が表示されません。 bufの値とTextBox9の値と両方をコピー表示する方法をお教えください。

  • excel2003 マクロ　複数セルに文字を追記

    オートフィルタ後、E列の文字が入力されているセルにのみ 頭に「花」という文字をいれたい。 ということをしたいです。 もともと入っている文字に追記をしたいのですが どうすればよいでしょうか？ オートフィルタした値は、すべて同じではないです。 アドバイスお願いします。 Sub オートフィルタ後花をつける() moji = "花" With Worksheets("Sheet1") 　　 .Range("E3",Range("E65536").End(xlUp)).SpecialCells(xlCellTypeVisible).Select Selection.Value = moji & ActiveCell.Value←これではだめですよね・・・ End With End Sub

  • フォームのCheck boxとOLEObjectのCheckboxのマクロの違い？

    エクセル2003です。 ワークシート上に複数個のチェックボックスを配置し、オンの場合、その左隣のセルの値を返すマクロを作成する場合についての質問です。 普段はフォームのCheck boxを使っています。 フォームのCheck boxなら Sub ChkBx() With ActiveSheet.CheckBoxes(Application.Caller) If .Value = xlOn Then MsgBox .TopLeftCell.Offset(0, -1).Value End If End With End Sub と、標準モジュールに一つだけプロシージャを書いて、複数個のCheck boxに同一のマクロを登録すれば簡単に出来ます。 ところがこれをOLEObjectのCheckboxでやってみようと思ったところ、フォームのように一つのプロシージャを使いまわすことができず、シートモジュールに以下のように各Checkboxごとのマクロを書かなくてはいけないようです。 Private Sub CheckBox1_Click() With OLEObjects("CheckBox1") If .Object.Value Then MsgBox .TopLeftCell.Offset(0, -1).Value End If End With End Sub Private Sub CheckBox2_Click() With OLEObjects("CheckBox2") If .Object.Value Then MsgBox .TopLeftCell.Offset(0, -1).Value End If End With End Sub Private Sub CheckBox3_Click() With OLEObjects("CheckBox3") If .Object.Value Then MsgBox .TopLeftCell.Offset(0, -1).Value End If End With End Sub 3つや4つくらいならどうってことはないのですが十数個もあるとかなり面倒です。 OLEObjectのCheckboxでももっと簡単にする方法はないのでしょうか？ それともわたしが何かOLEObjectのCheckboxの使い方について思い違いをしているのでしょうか？ ご教示をお願いいたします。

  • [VBA]型が一致しません

    EXCELWORKSHEET上で下記の処理をすると「型が一致しません」との エラーがでます。どうにも原因と対応策がわからず悩んでいます。 デバッグの良い方法ありませんでしょうか？ ＜現象＞ ＊列2上のセルを選択して、DELETEキーを押す。⇒エラーなし。 ＊しかし、列2上のセルとその他のセルを同時選択した上で、DELETEキーを押すと「型が一致しません。」のエラー。 頭の「If Target.Column Like 2 And Len(Target.Value) > 0 Then 」が悪さしているのはわかるのですが・・・。 Private Sub WORKSHEET_CHANGE(ByVal Target As Range) If Target.Column Like 2 And Len(Target.Value) > 0 Then Range("c" & Target.Row).Value = Now If Target.Column Like 2 And Len(Target.Value) > 0 Then 'B列の場合だけ確認 Dim rng As Range Set rng = ActiveSheet.Range("B:B").Find(What:=Target, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True, MatchByte:=True) If Not rng Is Nothing Then '発見した。 If rng.Address <> Target.Address Then '入力中セル以外で発見 Select Case MsgBox("過去に受け入れたLOTです。再度受入れますか？", vbYesNo) Case vbYes Range("B2").Activate Selection.End(xlDown).Select ActiveCell.Offset(0, 1).Activate ActiveCell.Value = Now ActiveCell.Offset(0, 1).Activate ActiveCell.Value = UserForm2.TextBox2.Value UserForm2.TextBox1.Value = "" UserForm2.TextBox2.Value = "" UserForm2.TextBox1.SetFocus Range("B2").Activate Selection.End(xlDown).Select Selection.Offset(1, 0).Select Case vbNo Range("B2").Activate Selection.End(xlDown).Select ActiveCell.ClearContents ActiveCell.Offset(0, 1).Activate ActiveCell.ClearContents UserForm2.TextBox1.Value = "" UserForm2.TextBox2.Value = "" UserForm2.TextBox1.SetFocus End Select End If End If End If End If End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する