人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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


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



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


1413711187
●拡大する

●質問者: ヘンリ
●カテゴリ:コンピュータ
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● きゃづみぃ
●1200ポイント ベストアンサー
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


ヘンリさんのコメント
きゃづみぃさんへ コードのご回答ありがとうございます。 さっそく実装させていただきました。 私のしたいことの大部分は実現できてますね。 ありがとうございます。 ただ細かい部分になるのですが、 いくつか気になるところがありましたので書かせていただきたいです。 まず横に連続で選択すると(2列以上まとめて選択すると)、メッセージボックスで上書きするか訊いてくるのですが、 これを横に複数選択した場合でもメッセージボックス開かないようにしていただくことは可能でしょうか。 もちろん、U列にすでにデータが存在する場合はメッセージボックスで上書きするかどうかを訊いてきてほしいです。 それから、今度は横ではなく縦でセルを複数選択する場合なのですが、 離れたセルをいくつか選択すると(いくつ選ぶと・・、などの条件は分からないのですが) ---------------------------------------------------------------------------- 実行時エラー '1004': アプリケーション定義またはオブジェクト定義のエラーです。 ---------------------------------------------------------------------------- 上記のようなエラーが発生してしまいます。 これを、離れたセルを複数選択しても(何個選択しても)、エラーにならないようにはできますでしょうか。 可能ならば、どうかよろしくお願いいたします。 また、ここからはただの私のワガママであり、はじめの説明文に書き忘れてしまったことなので、 もし可能ならば、という話になるのですが。 さらにこうして欲しいという条件が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列】にすでに何かの色が付いているだけの場合はデータとは見なさないようにしていただきたいです。 ---------------------------------------------------------------------------- ここまで読んでいただきまして誠にありがとうございます。 もし可能な部分があれば、その部分を反映させたコードを教えていただきたいです。 また、分かりにくい部分がありましたらどうかご指摘いただきたいです。

きゃづみぃさんのコメント
>|vb| 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, "T") <> "" Then If Cells(ar, ac) <> "" Then ActiveWindow.ScrollRow = ar If MsgBox("新しいデータで上書きしますか?", vbYesNo) = vbNo Then f = 2 End If End If Else f = 2 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 ||< 追加の分に対応しました。

きゃづみぃさんのコメント
おっと コメントが追加されてましたね。

きゃづみぃさんのコメント
コメントに対応しました。 >|vb| Private Sub CommandButton4_Click() Dim aa As Long Dim ar As Long Dim cc As Long ac = "U" cc = 0 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 cc = ar Then f = 2 Else 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 End If cc = ar 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 ||<

ヘンリさんのコメント
きゃづみぃさんへ こんなに早くご返答いただきまして、ありがとうございます! 今回のコードも本当に、私の理想に近いです。 ワガママにお付き合いいただきまして、ありがたいです。 ただ、少しだけ気になる箇所がありましたので書かせてください。 ?まず、 セルを縦に選択した場合にエラーが発生するようです。 それも連続したセル(2個以上選択したセル)を飛び飛びで選択した場合にエラーになります。 たとえば、ある1列において 1行目(セル選択) 2行目(セル選択) 3行目 4行目(セル選択) 5行目(セル選択) 上記のように選択した場合、 ---------------------------------------------------------------------------- 実行時エラー '1004': アプリケーション定義またはオブジェクト定義のエラーです。 ---------------------------------------------------------------------------- という窓が開いてしまいます。 ?また T列に文字列が一切ない場合(色だけ塗られている場合もですが)は、 メッセージボックス:「T列の作業がまだ終わっていません。」と開くようにして、その行のU列には何も書き込まないようにしていただきたいです。 (※書き込まないのですが、メッセージボックスを開いたときに、そのU列が見える位置にExcelをスクロールしていただきたいです。見えればどこでも構いません) それで、複数のセルを選択していてまだ動作の途中だった場合、メッセージボックスを閉じたら続きの行の処理を行うという流れだと理想的です。 ここまでで、 分かりにくい部分がありましたらどうかご指摘いただきたいです。

きゃづみぃさんのコメント
>|vb| Private Sub CommandButton4_Click() Dim aa As Long Dim ar As Long Dim cc As Long ac = "U" cc = 0 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.Areas(aa).Row + bb - 1 Else ar = Selection.Areas(aa).Row End If If cc = ar Then f = 2 Else 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 cc = ar 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 ||< エラーも出なくなったと思います。

ヘンリさんのコメント
きゃづみぃさんへ お返事が遅れました。すいません。 エラーに対応したコードに変更していただきまして、どうもありがとうございます。 本当に前回書かせていただいた状況下ではエラーが出なくなりまして、とても助かりました。 ただ、今回は一難去ってまた一難といいますか、違う部分で気になる結果がありましたので どうか書かせていただきたいです。 横に連続して複数選択した場合、その行だけでなく、選択したセルの数だけ(その行も含めて下に)入力されてしまうようです。 行を(行番号で)選択すると、【T列の作業がまだ終わっていません。】の窓が出現して【OK】を押し続けても永遠に窓が消えないという現象が起こったりします。 (そうなると、自分の場合Excelを閉じるにはパソコンをシャットダウンするしか方法が分からず、対処が分からないものでして。) ですので、 これを横に複数選択された場合でも(1行において離れたセルを選択された場合も複数選択された場合に含めます。)、その行で一回だけU列に入力するという仕様に変更することはできますでしょうか。 何度も申し訳ございません。

きゃづみぃさんのコメント
>|vb| 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 ||<

ヘンリさんのコメント
きゃづみぃさんへ 私のわがままに対応していただきまして、誠にありがとうございます。 今度はメッセージボックスが出続けることもなく、スムーズに動きます。 感謝させていただきます。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ