エクセルで水量が増えていく様子を作りたい

質問

先ほど、パワーポイントで同様の質問をした者です。
エクセルで、水槽の水が自動的に増えていくようなシュミレーションを作成したいのです。マクロでもいいのですが、マクロが全くわからないので、サンプルを教えていただければ助かります。
パワーポイントの方が向いているかと思いますが、グラフも同時に作りたいので、エクセルの方がいいのかなと・・・
急ぎなので、すぐ回答がほしいです。
よろしくお願いします。

回答No.1

misatoanna · ベストアンサー

> グラフも同時に作りたいので

水量がグラフと関連付づけて増えていく様子を描きたいのでしょうか。

でも、以下は、グラフとは全く関係なく、ただ水量が増えていくだけの
マクロです。

1.[Alt]を押しながらの[F11]で、Visual Basic Editor を開きます。
2.開いたウィンドウの[挿入]から[標準モジュール]を選択します。
3.次のモジュールをコピペして、Visual Basic Editor を閉じます。

Sub Test1()
　Dim WtrHT, WtrTP, WtrLF, WtrWD, TnkHT, WtAdd
　'
　With ActiveSheet.Shapes("Tank")
　　TnkHT = .Height
　　WtrTP = .Top + .Height
　　WtrLF = .Left
　　WtrWD = .Width
　End With
　ActiveSheet.Shapes. _
　　　AddShape(msoShapeRectangle, WtrLF, WtrTP, WtrWD, 0).Select
　Selection.ShapeRange.Name = "Water"
　With ActiveSheet.Shapes("Water")
　　.Fill.ForeColor.SchemeColor = 15
　　.Line.Visible = msoFalse
　End With
　'
　Do While WtAdd <= TnkHT
　　WtAdd = WtAdd + 0.2
　　ActiveSheet.Shapes("Water").Top = WtrTP - WtAdd
　　ActiveSheet.Shapes("Water").Height = WtrHT + WtAdd
　　DoEvents
　Loop
　Range("QQQ").Select
End Sub

4.シート内のK1あたりにでも、小さいオートシェイプの四角形を描き、その
　右クリックメニューから"マクロの登録"を選択して、Test1を指定します。

ここまで操作が完了したら、シート内にオートシェイプで適当なサイズの
四角形(水槽)を描き、それを選択して名前ボックスでTankという名前に変更
します。

マクロを登録したオートシェイプをクリックするとマクロが実行されます。
（水槽の底から水が次第に増えていく様子 ―― のつもりです。）

回答No.5

popuplt

マクロではなく関数と循環参照を使って遊んで見ました。
ASIMOVさま作成の図（B5:D15が水槽）を拝借しました。
[準備]
[B5]=ROW()-16+$A$1と入力　B5:D15にコピー。
B5:D15の範囲の文字を白に設定。
B5:D15を選択して、[条件付き書式設定]-[セルの値]-[次の値以上]-[0]
[書式]で塗りつぶしとフォントを水色にします。
フォームコントロールのチェックボックスを作成し、右クリックで
[コントロールの書式設定]-[リンクするセル]＝$B$1
[A1]=if(b1,a1+0.01,0)
[オプション]-[反復計算を行う]にチェックして、反復回数[1111]
準備が出来たら、チェックボックスをクリック。

お礼

お忙しい中ご回答いただき、ありがとうございます。
今後ともどうぞよろしくお願いします。

回答No.4

ASIMOV

こんなのも有ります
-------------------
Sub Sample()
　　ini0
　　For i = 15 To 6 Step -1
　　　　Application.Wait Now + TimeSerial(0, 0, 1)
　　　　mizu i
　　Next
End Sub
--------------------------
Sub ini0()
　　Range("B5:D15").Select
　　Selection.Borders(xlDiagonalDown).LineStyle = xlNone
　　Selection.Borders(xlDiagonalUp).LineStyle = xlNone
　　With Selection.Borders(xlEdgeLeft)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlMedium
　　　　.ColorIndex = xlAutomatic
　　End With
　　With Selection.Borders(xlEdgeTop)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlMedium
　　　　.ColorIndex = xlAutomatic
　　End With
　　With Selection.Borders(xlEdgeBottom)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlMedium
　　　　.ColorIndex = xlAutomatic
　　End With
　　With Selection.Borders(xlEdgeRight)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlMedium
　　　　.ColorIndex = xlAutomatic
　　End With
　　Selection.Borders(xlInsideVertical).LineStyle = xlNone
　　Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
　　With Selection.Interior
　　　　.ColorIndex = 2
　　　　.Pattern = xlSolid
　　　　.PatternColorIndex = xlAutomatic
　　End With
　　Range("C3:C4").Select
　　Selection.Borders(xlDiagonalDown).LineStyle = xlNone
　　Selection.Borders(xlDiagonalUp).LineStyle = xlNone
　　With Selection.Borders(xlEdgeLeft)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlMedium
　　　　.ColorIndex = xlAutomatic
　　End With
　　Selection.Borders(xlEdgeTop).LineStyle = xlNone
　　Selection.Borders(xlEdgeBottom).LineStyle = xlNone
　　With Selection.Borders(xlEdgeRight)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlMedium
　　　　.ColorIndex = xlAutomatic
　　End With
　　Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
　　With Selection.Interior
　　　　.ColorIndex = 2
　　　　.Pattern = xlSolid
　　　　.PatternColorIndex = xlAutomatic
　　End With
　　Range("A1").Select
End Sub
-----------------------------
Sub mizu(l)
　　Range("B" & l & ":D" & l).Select
　　With Selection.Interior
　　　　.ColorIndex = 33
　　　　.Pattern = xlSolid
　　　　.PatternColorIndex = xlAutomatic
　　End With
　　Range("A1").Select
End Sub

お礼

お忙しい中ご回答いただき、ありがとうございます。
とても助かりました。
今後ともどうぞよろしくお願いします。

回答No.3

mitarashi

かねてから興味を持っていた、XL2000のEventのヘルプに記述されていたコードの理解と、条件付書式による棒グラフの実現のテストのためにやってみました。前者は自分自身も今回初めて理解できた気がしますので、分かりやすいとは思えませんがあしからず。

１．クラスモジュール myTimerClass　-CopyRight Microsoft(HELPより)
（VBEで挿入／クラスモジュールで生成されるClass1の名前を付け替えて、記述してください）
Public Event UpdateTime(ByVal dblJump As Double)
Public Sub TimerTask(ByVal Duration As Double)
Dim dblStart As Double
Dim dblSecond As Double
Dim dblSoFar As Double
dblStart = Timer
dblSoFar = dblStart
Do While Timer < dblStart + Duration
If Timer - dblSoFar >= 1 Then
dblSoFar = dblSoFar + 1
RaiseEvent UpdateTime(Timer - dblStart)
End If
Loop
End Sub

２．シートモジュール
コントロールツールボックスのコマンドボタン1個を設ける。
Private WithEvents myTimer As myTimerClass

Private Sub CommandButton1_Click()
Range("B1").Value = 0
Set myTimer = New myTimerClass
Call myTimer.TimerTask(10.1)
End Sub
Private Sub mytimer_UpdateTime(ByVal dblJump As Double)
Range("B1").Value = CLng(dblJump)
DoEvents
End Sub

３．上記シートのA1～A10に条件付書式を設定する
条件1　数式が　=ROW()>(10-$B$1)、書式：セルのパターン水色
以上により、コマンドボタンをクリックすると、A10→A1まで、1秒毎に水色に変わり、水量が増えていきます。

４．またはB1セルのみを用いた棒グラフを設けても良いです。Y軸の上限、下限は手動で設定しておいて下さい。データ系列の書式設定／オプションで、棒の重なり0、棒の間隔共に0に設定すると、グラフ内全体に一本の棒が広がる体裁になります。

お礼

お忙しい中ご回答いただき、ありがとうございます。
少しはマクロを勉強しないと・・・と思いました。
今後ともどうぞよろしくお願いします。

回答No.2

misatoanna

＜＃１の補足です＞

モジュールの最後のほうにある
> Range("QQQ").Select
について、説明が足りませんでした。

プログラムが終了したときに、"水"が選択されたままの状態になる
のを避けるために特定のセルを選択させるコマンドです。

この行を削除するだけでもよいのですが、水槽に見立てたオート
シェイプの陰になるセルをひとつ選択してQQQという名前をつけて
おいたほうがよいと思います・・・・。

お礼

お忙しい中ご回答いただき、ありがとうございます。やってみて感動しました。おかげさまで何とかなりそうです。
今後ともどうぞよろしくお願いします。