1413711187 次の動作をするExcel(エクセル)2007のVBA(マクロ)コードを教えていただきたいです。



【ある条件下で、テキストボックスに入力されている文字列をそのまま入力して、黄色く塗りつぶす】VBAコードになります。



(※長くなってしまったので、具体的な「続き」を、このページ下部の「コメント」欄に書かせていただきます。
よろしくおねがいします。)

回答の条件
  • 1人1回まで
  • 13歳以上
  • 登録:2014/10/19 18:33:07
  • 終了:2014/10/22 21:01:46

ベストアンサー

id:taknt No.1

きゃづみぃ回答回数13537ベストアンサー獲得回数11982014/10/19 22:23:43

ポイント1200pt
Private Sub CommandButton4_Click()
    Dim aa As Long
    Dim ar As Long
    
    ac = "U"
    
    For aa = 1 To Selection.Areas.Count
        For bb = 1 To Selection.Areas(aa).Count
             f = 1
             If Selection.Areas(aa).Count > 1 Then
                ar = Selection(bb).Areas(aa).Row
            Else
                ar = Selection.Areas(aa).Row
             End If
             
             If Cells(ar, ac).Interior.Pattern <> xlNone Or Cells(ar, ac) <> "" Then
                ActiveWindow.ScrollRow = ar
                
                If MsgBox("新しいデータで上書きしますか?", vbOKCancel) = vbCancel Then
                    f = 2
                End If
            End If
            
            If f = 1 Then
                Cells(ar, ac) = TextBox1.Text
                Cells(ar, ac).Interior.ColorIndex = 6
            End If
        
        Next bb
        
    Next aa
End Sub

他7件のコメントを見る
id:taknt
Private Sub CommandButton4_Click()

    Dim aa As Long
    Dim ar As Long

    ac = "U"
    For aa = 1 To Selection.Areas.Count
        For bb = 1 To Selection.Areas(aa).Rows.Count
            f = 1
            
            ar = Selection.Areas(aa).Row + bb - 1
            
            If Cells(ar, "T") <> "" Then
                If Cells(ar, ac) <> "" Then
                    ActiveWindow.ScrollRow = ar
                    If MsgBox("新しいデータで上書きしますか?", vbYesNo) = vbNo Then f = 2
                End If
            Else
                f = 2
                ActiveWindow.ScrollRow = ar
                MsgBox "T列の作業がまだ終わっていません。"
            End If

            If f = 1 Then
                Cells(ar, ac) = TextBox1.Text
                Cells(ar, ac).Interior.ColorIndex = 6
            End If
        Next bb
    Next aa
End Sub
2014/10/21 22:13:31
id:egaosaiko

きゃづみぃさんへ

私のわがままに対応していただきまして、誠にありがとうございます。

今度はメッセージボックスが出続けることもなく、スムーズに動きます。

感謝させていただきます。

2014/10/21 22:39:32
  • id:egaosaiko
    (ここまで見ていただいてありがとうございます。)



    【Sheet1】のU列のみでの動作になります。

    教えていただきたいのは、テキストボックスに入力されている文字列をそのまま入力して、黄色く塗りつぶすVBAコードです。


    まず、(画像もアップさせていただいたのですが)
    動作対象となるU列の上の方に
    ラベル(Label1、アクティブXコントロール)を設置して、その上にテキストボックス(TextBox1、アクティブXコントロール)とコマンドボタン(CommandButton4、アクティブXコントロール)を設置します。



    ●動作の流れ

    ①テキストボックスに文字列を入力します。
     ↓↓↓
    ②「テキストボックスに入力された文字列」を入れたいセルを選択します。
    (離れたセルも含め、セルの複数選択もできるようにしたいです。)
     ↓↓↓
    ③コマンドボタンを押します。
     ↓↓↓
    ④選択された全てのセルの(行の)U列に、「テキストボックスに入力された文字列」を入力し、黄色く塗りつぶします。
    また、U列のみでの動作になるので、選択したセルがどこの列でも(横に複数選択した場合でも)その行のU列に「テキストボックスに入力された文字列」を入力し、黄色く塗りつぶしたいです。



    ●ただし条件がありまして、すでにその行のU列に【何かしらのデータ】が存在する場合はメッセージボックスで
    新しいデータ(文字列)で上書きするかどうかを問うてくる仕様にしたいです。

    ※ここで言う【何かしらのデータ】というのは、文字列だけではなく
    セルに何かの色が付いているだけでもデータも見なし、
    スペース(半角全角問わず)が入っているだけでもデータが入っていると見なします。
    ↑↑
    (スペースについては、見た目には何も存在しないように見えますがデータとして扱いたいです。)


    そして、選択したセルの行のU列のセル(分かりにくい日本語ですいません。)に
    何もデータが存在しない場合は自動的に(Excel画面をスクロール移動することなくその画面のまま)、「テキストボックスに入力された文字列」を入力し、黄色く塗りつぶします。

    何かしらのデータが存在した場合には、入力するセルが見える場所までExcel画面をスクロール移動して(そのセルが見えるならどこでもいいのですが)
    【メッセージボックス:新しいデータで上書きしますか?】という窓を開き、
    【はい】を選んだ場合は「テキストボックスに入力された文字列」を入力し、黄色く塗りつぶします。

    【いいえ】を選んだ場合は、何も入力しません(元から存在するデータのまま変化させません)。



    ●アップした画像で言いますと、
    【Excelの行番号】
    9行目
    11行目
    12行目
    14行目

    を同時に選択した場合に一回だけ実行した結果になっています。




    そもそも上記で書いた通りに実現可能なのかどうかが分からないのですが、
    可能ならば、どうかそのVBAコードを教えていただきたいです。


    ※ここまでで、説明が分かりにくい部分や情報の不備などがありましたら、
    コメント欄でご指摘をお願いいたします。

  • id:Yoshiya
    シートのサンプルがあるのであれば、オンラインストレージからダウンロードできるといいですね。

    例えば、firestorage(http://firestorage.jp/)とか?
  • id:egaosaiko
    Yoshiya さんへ

    コメントしていただきまして、ありがとうございます。

    オンラインストレージという無料サービスがあったんですね!
    教えていただき感謝です。


    サンプルとも言えないようなサンプルですが、
    URLを載せさせていただきますね。
    最初にアップした画像のまんまなので、何の参考にもならないかもしれないですが。

    http://firestorage.jp/download/dd783916f628a177f72b7a5877066098e7555db4
    ダウンロードパスワード :tzyxw8jh

  • id:Yoshiya
    とりあえず作ってみました。

    Option Explicit

    Private Sub CommandButton4_Click()

    Dim Text As String
    Dim SelectRow As Range
    Dim SelectRowNo As Long
    Dim Res As Integer

    'テキストボックスの文字列を取得(文字列無しの場合は終了)
    If TextBox1.Value = "" Then
    Exit Sub
    End If
    Text = TextBox1.Value

    '選択されたセルをチェック(選択順)
    For Each SelectRow In Selection.Rows
    SelectRowNo = SelectRow.Row - 1
    With Range("U1").Offset(SelectRowNo)
    'セルに文字が無く、かつセルが塗りつぶされていない
    If .Value = "" And .Interior.ColorIndex = xlNone Then
    .Value = Text
    .Interior.ColorIndex = 6
    Else
    .Select
    Res = MsgBox("新しいデータで上書きしますか?", vbYesNo + vbQuestion)
    If Res = vbYes Then
    .Value = Text
    .Interior.ColorIndex = 6
    End If
    End If
    End With
    Next SelectRow

    End Sub

    保存場所(パスワード:hquestion)
    http://firestorage.jp/download/8f984771dcd5fc2b027910bcbda4187d2d2f14e4
  • id:egaosaiko
    Yoshiya さんへ

    この度もVBAコードを考えていただきまして、誠にありがとうございます。
    オンラインストレージでダウンロードさせていただきました。
    私の分かりにくい説明をほぼ忠実に再現していただき、嬉しいです!


    ただ、
    何回も試してみて気になる部分がありましたので書かせていただけないでしょうか。

    条件は分からないのですが、何度か実行しているとたまに発生することがあります。

    それは、前回選択したセルに対して上書きするかどうか聞いてきて、
    (「はい」を選んでも「いいえ」を選んでも)そこから「一番最近選択されたセルの行のU列」に入力する仕様になっているようです。


    結果は変わらないのですが、ちょっと気になりまして。



    また、ここからの2つは私のわがままなのでもし可能ならばお願いしたいところなのですが、

    【1つ目】
    コメント欄に書かせていただいた説明文で

    ----------------------------------------------------------------------------
    ●ただし条件がありまして、すでにその行のU列に【何かしらのデータ】が存在する場合はメッセージボックスで
    新しいデータ(文字列)で上書きするかどうかを問うてくる仕様にしたいです。

    ※ここで言う【何かしらのデータ】というのは、文字列だけではなく
    セルに何かの色が付いているだけでもデータも見なし、
    スペース(半角全角問わず)が入っているだけでもデータが入っていると見なします。
    ↑↑
    (スペースについては、見た目には何も存在しないように見えますがデータとして扱いたいです。)
    ----------------------------------------------------------------------------
    上記のように説明してしまったのですが、これを下のように訂正させていただきたいのです。

    ↓↓↓

    ----------------------------------------------------------------------------
    ●ただし条件がありまして、すでにその行のU列に【何かしらのデータ】が存在する場合はメッセージボックスで
    新しいデータ(文字列)で上書きするかどうかを問うてくる仕様にしたいです。

    ※ここで言う【何かしらのデータ】というのは、

    【U列】に
    ①何かしらの文字列が入っている状態を指します。
    ②また、スペース(半角全角問わず)だけでもデータが入っていると見なします。
    ↑↑
    (スペースについては、見た目には何も存在しないように見えますがデータとして扱いたいです。)

    ※ただし、【U列】にすでに何かの色が付いているだけの場合はデータとは見なさないようにしていただきたいです。
    ----------------------------------------------------------------------------

    というのも、私の使うExcelはアクティブセルの行に色を付けているですが(セルを選べばその行に必ず色が付いてしまうのです)、
    説明文やサンプルに実装するのを忘れていまして。




    【2つ目】
    U列というのはある作業を終えたらチェックを入れる列なのですが、
    これは一個左の列【T列】のチェックを終えていないと書き込まないようにしている列なのです。
    T列でのチェックなしに、いきなりU列でチェックすることは原則不可能にしたいところがありまして、
    流れ上、T列が先にあって→U列という順番になっているのです。
    (同じ行においてT列に何の文字列もないのに、いきなりU列に文字列が存在しているということは回避したいのです。)

    そこで、テキストボックスに入力された文字列をコマンドボタンで実行するときに、
    (同じ行において)左の列である【T列】に何かしらの文字列が存在することを確認してから【U列】に書き込むようにしていただきたいのです。

    ●流れはこのような感じになります。
    ↓↓↓
    ①テキストボックスに文字列を入力。
    ②入力したい行のセルを選択(複数選択でも可能)。
    ③コマンドボタンを押す。
    ┣T列に文字列があれば、そのままExcelをスクロールすることもなく、メッセージボックスを開くこともなくその場で自動入力してほしいです。
    ┗その行のT列に何の文字列もない場合(チェックが入っていない場合)、
    メッセージボックス:「T列の作業がまだ終わっていません。」と開くようにして、その行のU列には何も書き込まないようにする。
    (※書き込まないのですが、メッセージボックスを開いたときに、そのU列が見える位置にExcelをスクロールしていただきたいです。見えればどこでも構いません)


    ----------------------------------------------------------------------------
    ※T列でいう文字列というのは、

    【T列】に
    ①何かしらの文字列が入っている状態を指します。
    ②また、スペース(半角全角問わず)だけでもデータが入っていると見なします。
    ↑↑
    (スペースについては、見た目には何も存在しないように見えますがデータとして扱いたいです。)

    ※ただし、【T列】にすでに何かの色が付いているだけの場合はデータとは見なさないようにしていただきたいです。
    ----------------------------------------------------------------------------


    色をデータとして見なさない仕様がいい、というのはこちらのサンプルを見て頂くと意味がわかるかもしれません。
    選択したセルの行に色がつきますので。
    http://firestorage.jp/download/7ae7e30e3f76e176dee560b8b62e0f35e6167cc8
    ダウンロードパスワード:xtvqxx1c



    かなりの長文になってしまいました。
    もし可能な部分があれば、その部分を反映させたコードを教えていただきたいです。

    また、分かりにくい部分がありましたらご指摘いただきたいです。


  • id:Yoshiya
    修正してみました。


    Private Sub CommandButton4_Click()

    Dim Text As String
    Dim SelectRow As Range
    Dim SelectRowNo As Long
    Dim Res As Integer

    'テキストボックスの文字列を取得(文字列無しの場合は終了)
    If TextBox1.Value = "" Then
    Exit Sub
    End If
    Text = TextBox1.Value

    '選択されたセルをチェック(選択順)
    For Each SelectRow In Selection.Rows
    SelectRowNo = SelectRow.Row - 1

    If SelectRowNo > 8 Then
    With Range("U1").Offset(SelectRowNo)
    'T列セルに文字が無い場合
    If Range("T1").Offset(SelectRowNo) = "" Then

    'テスト用
    Res = MsgBox("対象番号:" & SelectRowNo - 7 & vbCr & vbCr & "T列の作業がまだ終わっていません。", vbOKOnly + vbExclamation)

    '本番用
    ' Res = MsgBox("T列の作業がまだ終わっていません。", vbOKOnly + vbExclamation)

    Else
    'U列セルに文字が無く、かつセルが塗りつぶされていない
    If .Value = "" Then
    If .Interior.ColorIndex = xlNone Then
    .Value = Text
    .Interior.ColorIndex = 6
    End If
    Else
    .Select
    'テスト用
    Res = MsgBox("対象番号:" & SelectRowNo - 7 & vbCr & vbCr & "新しいデータで上書きしますか?", vbYesNo + vbQuestion)

    '本番用
    ' Res = MsgBox("新しいデータで上書きしますか?", vbYesNo + vbQuestion)
    If Res = vbYes Then
    .Value = Text
    .Interior.ColorIndex = 6
    End If
    End If
    End If
    End With
    End If
    Next SelectRow

    'セル選択解除
    Range("A1").Select

    End Sub


    実行行がわかりやすい様に、メッセージボックスに行数を追加しました。
    (テストコードなので、実際に使用する際は本番用に置き換えてください。)


    修正コードはsample2.xlsmに上書きしています。
    http://firestorage.jp/download/e98b850c168dfd0c8e702ef93ecb958609fd875e
  • id:egaosaiko
    Yoshiya さんへ


    対応していただきまして、ありがとうございます。
    また、
    sample2.xlsmに上書きという配慮ありがたいです。

    さっそくダウンロードさせていただき、試させていただきました。



    メッセージボックス:「T列の作業がまだ終わっていません。」を表示する仕様にしていただきましてありがとうございます。


    ただ、気になるところがあったのでまたコメントをさせていただきたいです。
    よろしくお願いいたします。


    ①コマンドボタンを押すと、アクティブセルが1行目に移動してしまうという結果になるようです。
    テキストボックスの内容を、「選択したセルの行のU列」に書き込む仕様にしていただけますと助かります。


    ②メッセージボックス:「T列の作業がまだ終わっていません。」を表示するときなのですが、
    そのメッセージボックスを開く対象のセル(U列)が見える位置にExcel画面をスクロールしていただけると個人的にとても便利になるので、ご対応いただけないでしょうか。
    そのセル(U列)が見える位置なら、どこにスクロールしていただいても構いません。


    何度も申し訳ございません。


    ここまでで、分かりにくい説明がありましたらどうかご指摘をお願いいたします。




  • id:Yoshiya
    ヘンリさま

    >①コマンドボタンを押すと、アクティブセルが1行目に移動してしまうという結果になるようです。
    >テキストボックスの内容を、「選択したセルの行のU列」に書き込む仕様にしていただけますと助かります

    処理が完全に終了した際、選択したセルを解除する為に、わざとA1セルを選択しています。
    (エクセルの仕様上、選択したセルを解除(セルが選択されていない状態)にするのは不可能)
    最後に処理したセルを選択した状態で終了させるのであれば、「Range("A1").Select」を削除すればOKです。


    >②メッセージボックス:「T列の作業がまだ終わっていません。」を表示するときなのですが、
    >そのメッセージボックスを開く対象のセル(U列)が見える位置にExcel画面をスクロールしていただけると個人的にとても便利に>なるので、ご対応いただけないでしょうか。
    >そのセル(U列)が見える位置なら、どこにスクロールしていただいても構いません。

    これはちょっと難しいです。
    理由は、ディスプレイの解像度が違うからです。
    通常、メッセージボックスはアクティブウィンドの真ん中に表示される様になっています。
    画面の真ん中が選択されたセルがある場合、メッセージボックスに被るのは避け様がありません。
    これを回避する方法としては。アクティブウィンドの真ん中よりも上ないしは下に選択したセルをスクロールさせることになるのですが、移動させる場所が特定できない状態では、何とも仕様がありません。


    (変更したソースコード)

    Private Sub CommandButton4_Click()

    Dim Text As String
    Dim SelectRow As Range
    Dim SelectRowNo As Long
    Dim Res As Integer

    'テキストボックスの文字列を取得(文字列無しの場合は終了)
    If TextBox1.Value = "" Then
    Exit Sub
    End If
    Text = TextBox1.Value

    '選択されたセルをチェック(選択順)
    For Each SelectRow In Selection.Rows
    SelectRowNo = SelectRow.Row - 1

    If SelectRowNo > 7 Then
    With Range("U1").Offset(SelectRowNo)
    'T列セルに文字が無い場合
    If Range("T1").Offset(SelectRowNo) = "" Then


    'テスト用
    Res = MsgBox("対象番号:" & SelectRowNo - 7 & vbCr & vbCr & "T列の作業がまだ終わっていません。", vbOKOnly + vbExclamation)

    '本番用
    ' Res = MsgBox("T列の作業がまだ終わっていません。", vbOKOnly + vbExclamation)

    Else
    'U列セルに文字が無く、かつセルが塗りつぶされていない
    If .Value = "" Then
    .Value = Text
    If .Interior.ColorIndex = xlNone Then
    .Interior.ColorIndex = 6
    End If
    Else
    .Select

    'テスト用
    Res = MsgBox("対象番号:" & SelectRowNo - 7 & vbCr & vbCr & "新しいデータで上書きしますか?", vbYesNo + vbQuestion)

    '本番用
    ' Res = MsgBox("新しいデータで上書きしますか?", vbYesNo + vbQuestion)
    If Res = vbYes Then
    .Value = Text
    .Interior.ColorIndex = 6
    End If
    End If
    End If
    End With
    End If
    Next SelectRow

    'セル選択解除
    ' Range("A1").Select

    End Sub


    修正したワークシートの保存場所
    http://firestorage.jp/download/f2bb0972c8bf52af8faac80204627f2d3d4ea11a
  • id:egaosaiko
    Yoshiya さんへ

    私の無理難題について分かりやすく解説していただきまして、
    ありがとうございます。

    VBAでも状況により出来ること、出来ないことがあるという分別がついていない自分にはとてもありがたいです。


    さっそく新しいコードを試させていただきました。
    かなり理想に近づいてきたと思います。

    僭越ながら、今回も気になる部分がありましたので書かせていただきたいです。


    ①行番号を選択した場合と、上書きした場合は黄色く塗りつぶしてくれるのですが、
    それ以外だと文字列を入力するだけで黄色く塗りつぶさないようです。

    これを文字列を入力するときは必ず、黄色く塗りつぶすという仕様に変更することは可能でしょうか。


    ②ある1行において、離れたセルを複数選択した場合(例:Q9とS9を同時に選択)、セルを1つずつ処理するようでして、
    必ず上書きするか訊いてくる仕様だと思いますので、これを同じ行で複数選択された場合は(連続で選択された場合も離れて選択された場合も)、一回だけ選択されたと扱う(まとめてセル一個として扱う)仕様にすることはできますでしょうか。


    今回も分かりにくい書き方になってと思いますので、伝わなかった部分はどうかご指摘をお願いいたします。
    毎回最後まで読んでいただきまして、ありがとうございます。

  • id:Yoshiya
    ヘンリ様

    >①行番号を選択した場合と、上書きした場合は黄色く塗りつぶしてくれるのですが、
    >それ以外だと文字列を入力するだけで黄色く塗りつぶさないようです。

    >これを文字列を入力するときは必ず、黄色く塗りつぶすという仕様に変更することは可能でしょうか。

    上記の不具合は私のミスです。 修正可能です。

    修正前)
    'U列セルに文字が無く、かつセルが塗りつぶされていない
    If .Value = "" Then
    .Value = Text
    If .Interior.ColorIndex = xlNone Then
    .Interior.ColorIndex = 6
    End If

    修正後)
    'U列セルに文字が無い
    If .Value = "" Then
    .Value = Text
    .Interior.ColorIndex = 6



    >②ある1行において、離れたセルを複数選択した場合(例:Q9とS9を同時に選択)、セルを1つずつ処理するようでして、
    >必ず上書きするか訊いてくる仕様だと思いますので、これを同じ行で複数選択された場合は(連続で選択された場合も
    >離れて選択された場合も)、一回だけ選択されたと扱う(まとめてセル一個として扱う)仕様にすることはできますでしょうか。

    セルの選択を行単位で考えていたので、同一行に選択セルが複数かる場合は想定していませんでした。
    それと、同一列・複数行の処理を一括で行うとすると、アルゴリズムそのものを考えなおさなければなりません。
    とりあえず考えてみます。
  • id:egaosaiko

    Yoshiya 様へ

    ご返答いただきまして、ありがとうございます。

    さっそく修正箇所を実装させていただきました。

    ①については、エラーもなにもなくスムーズに機能させていただきまして、
    非常にありがたい限りです。


    ②についてですが、大変なお手数をおかけしますこと申し訳ございません。
    私自身も普段は、1行において離れた選択はあまりしないのですが、
    もしものときも考えて先に対応させておいた方がいいかもしれないという願望からワガママを書かせていただきました。


    急ぎなどではありませんので、
    ぜひYoshiyaさんの生活スタイルの方を優先していただいて、
    もしお時間の余裕がありましたらお考えになっていただけると嬉しいです。


    毎回ありがとうございます。

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

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

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

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