こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

excel VBA 色をセルに自動的に付ける

エクセル2000を使用していて、VBA初心者で勉強中の者です。
タイムテーブルを作っています。
入力はユーザーフォームを使っています。
コマンドボタンを押すとtextboxにある値を判断してセルに色を付けるマクロを教えてください。
タイムテーブルは列は15分で1列使い、1時間で4列です。
1曜日は4行分使い、4行目に予定時間(textbox2)が入ります。
15分なら0.25 30分なら0.5 1時間は1 ・・・
ユーザーフォームの登録ボタンをクリックした時4行目に入力される値で
判断して、例えば0.15ならセルを1つ塗りつぶし、1時間なら4列分塗りつぶすマクロを教えてください。
塗りつぶすセルの値が入っているのはtextbox2
色は ColorIndex = 33
textbox2の値が0.01~0.25は1列分塗りつぶし
       0.26~0.5は2列分塗りつぶし
       0.51~0.75は3列分塗りつぶし
       0.76~1は4列分塗りつぶし
       1.01~0.25は5列分塗りつぶし
       ・・・
       4.76~5は20列分塗りつぶし
よろしくお願いします。
以下はユーザーフォームの登録ボタンを押す時のコードです。
Private Sub CommandButton1_Click()
'未入力なら中止
If ComboBox2.Value = "" Then
MsgBox "時間を入力"
Cancel = True
Exit Sub
ElseIf ComboBox3.Value = "" Then
MsgBox "時間を入力"
Cancel = True
Exit Sub
End If

Call Macro登録
End Sub


Sub Macro登録()
    With ActiveSheet
.Cells(行, 列).Value = ComboBox1.Text'1行目の値
.Cells(行 + 1, 列).Value = TextBox1.Text'2行目の値
.Cells(行 + 2, 列).Value = ComboBox2.Text & "~" & ComboBox3.Text'3行目の値
.Cells(行 + 3, 列).Value = TextBox2.Value'4行目の値
    End With
End Sub

投稿日時 - 2009-11-24 15:36:06

QNo.5472459

すぐに回答ほしいです

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.2

一応、こんな感じだと思います
-------------------------------------
Private Sub CommandButton?_Click()
' 色付けのボタンの番号↑を?に書く
 Dim x As Single
 x = Int((TextBox1.Value - 0.01) * 4)
'  ↓行と列を指定してください
 行 = ??
 列 = ??
 Range(Cells(行, 列), Cells(行 + 3, 列 + x)).Select
 With Selection.Interior
  .ColorIndex = 33
 End With
End Sub

投稿日時 - 2009-11-24 23:56:21

ANo.1

試しに作ってみましたが、あくまで試験用のコードです。TextBox1に任意の数を入力後、CommandButton1をクリックしてください。動作後アクティブセルが一つ下がりますので、連続的に試験できます。0.251でも2列色塗りしてしまいます。お気に召したらご採用下さい。
Private Sub CommandButton1_Click()
Dim tempDbl As Double
tempDbl = CDbl(TextBox1.Value)
If tempDbl >= 0.01 Then
ActiveCell.Resize(, getColumnCount(tempDbl)).Interior.ColorIndex = 33
End If
ActiveCell.Offset(1, 0).Activate
End Sub

Function getColumnCount(targetNumber As Double) As Long
Dim tempLng As Long

tempLng = CLng(targetNumber * 100)
getColumnCount = (tempLng \ 25) + IIf((tempLng Mod 25) > 0, 1, 0)
End Function

投稿日時 - 2009-11-24 23:51:49

あなたにオススメの質問