[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『抽選システムの作成』（ぴん）
あらかじめ関数を使用して抽出した４桁の数字SHEET１のE2のセル
をもとに別シートでいかにも抽選しているようにみせたいのですが、
何か面白く表示させることができないでしょうか？
＜ 使用 Excel：Excel2013、使用 OS：Windows8 ＞
シート上の関数だけで、実現するんですか？
VBAでマクロを作るっていうのもありですか？
（まっつわん） 2017/02/27(月) 16:23
おもしろい といっても、ひとそれぞれです。
たとえば こうしたら、こうなって、あぁなって つぎにこうなったら こうなる という そういったイメージだけでも、びんさんが考えて提示すべきでは？
また、まっつわんさんも言っておられるように、どのように実現したいのか？ 関数のみで？ マクロもあり？
マクロもありなら、
[[20121112093649]] 『がらがらを作りたいのですが・・・』（ラッキー男）
こういったものと当選番号を組み合わせるとか、あるいは、いっそのこと ベクター あたりで 抽選ソフト を検索すると 無償のものもたくさんでてくるのではないですか？
（ β） 2017/02/27(月) 16:34
2枚の画像で考えた場合、貼った画像の.ShapeRange.ThreeD.RotationXプロパティを0～90まで変化させると、画像が回転してだんだん細くなって見えます。逆にすれば、太くなります。（Xなら横回転、Yなら縦回転） 1組目の画像をだんだん細くした後、2組目の画像をだんだん太くするようコーディングすると、1枚の絵がくるっ、と回転して切り替わる、という演出ができます。
更に、10枚の数字画像を同じ座標に貼り付け、これを4組並べておきます。ランダムで4桁の数字を2組用意し、1組目の各桁を1ずつ増加させていき、2組目に一致した桁から更新を止めていけば、駅の表示器のパタパタのように、数字が1桁ずつ回っていくような感じにできるでしょう。いかがでしょうか。
でもって、作成したいならば、教えたキーワードを徹底的に調べて、試してくださいね。
（???） 2017/02/27(月) 16:51
検索したらこんなの見つかりましたけど、
応用できますかねぇ。。。
http://www.geocities.jp/ttak_ask/office_docu/ec5.html
でも、ちょっと、0から作るお手伝いは難しいかもです。
検索したら何かいいのが見つかるかもですよ？
まぁ、フリーソフト探すのが一番気が楽でいいと思います。
（まっつわん） 2017/02/27(月) 17:09
＞いかにも抽選しているようにみせたいのですが
カラクリが分かっている者には、当たり前の事しか起きない。 マジシャンも同じようなもんでしょうね。若干、むなしい。
一案作ってみました。
下記コードをSheet2のシートモジュールに貼り付けて、「rattle」を実行してください。
<Sheet2 結果図> Sheet1のE2セルに「2359」がある場合
行 _______A_______ _B_ _C_ _D_ _E_ 1 カウントダウン ｜← 0 →｜ (※B2:E2のセルは結合してください) 2 当選番号 2 3 5 9 3 4 5 4 1 0 5 7 7 4 9 6 9 6 0 5 : : : : : :
’－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub rattle()
Const Duration As Long = 26 'カウントダウンのベース長
Dim NN As Long, LL As Long
Dim rowNum As Long, delta As Long
Dim Dice As Variant
Randomize
Dice = getDice '出目を取得
'初期化
Range("B2:E2").Value = Empty
Range("B4:E13").Interior.Pattern = xlNone
Range("B4:E13").Font.ColorIndex = xlAutomatic
For LL = 0 To 3
Range("B4:B13").Offset(0, LL).Value = getRandOrder '０から９の乱数を埋める
Next LL
rowNum = 3 '初期値設定
delta = 1 '昇降フラグ
'カウントダウン開始
For LL = 2 To 5
Range("B1").Value = getCountDownNum(rowNum, delta, LL, Duration, Dice(LL - 1))
Do
Application.Wait [Now() + "0:00:0.1"] '待ちルーチンの長さを調整
rowNum = rowNum + delta
Call coloring(rowNum, delta) '行をハイライト
If rowNum >= 13 Then 'ハイライトの昇降を切替
delta = -1
ElseIf rowNum <= 4 Then
delta = 1
End If
Range("B1").Value = Range("B1").Value - 1
If Range("B1") = 0 Then 'カウントダウン終了
Cells(2, LL) = Cells(rowNum, LL)
Cells(rowNum, LL).Interior.Color = vbRed
Cells(rowNum, LL).Font.Color = vbYellow
Exit Do
End If
Loop
If LL <= 4 Then
Application.Wait [Now() + "0:00:1"] '1文字確定後、１秒待つ
End If
Next LL
Call coloringLast(rowNum)
Application.ScreenUpdating = True '念の為
End Sub
Private Function getDice()
Dim Ans As Variant, NN As Long
Dim Dice(1 To 4) As Long
Ans = Right("0000" & Sheets("Sheet1").Range("E2").Value, 4)
For NN = 1 To 4
Dice(NN) = CLng(Mid(Ans, NN, 1))
Next NN
getDice = Dice
End Function
Private Sub coloring(aimedRow As Long, delta As Long)
Dim KK As Long
For KK = 2 To 5 'B列～E列
With Cells(aimedRow, KK)
With .Offset(-delta)
If .Interior.Color <> vbRed Then
.Interior.Color = xlNone
End If
End With
If .Interior.Color <> vbRed Then
.Interior.Color = vbYellow
End If
End With
Next KK
End Sub
Private Sub coloringLast(aimedRow As Long)
Dim KK As Long
For KK = 2 To 4 'B列～F列
With Cells(aimedRow, KK)
If .Interior.Color <> vbRed Then
.Interior.Color = xlNone
End If
End With
Next KK
End Sub
Private Function getCountDownNum(ByVal rowNum, ByVal delta, colNum, Duration, target)
Dim pos As Long
Do
pos = pos + 1
rowNum = rowNum + delta
If pos > Duration Then
If Cells(rowNum, colNum).Value = target Then
Exit Do
End If
End If
If rowNum >= 13 Then
delta = -1
ElseIf rowNum <= 4 Then
delta = 1
End If
Loop
getCountDownNum = pos
End Function
Private Function getRandOrder()
Dim NN As Long
Dim RndNum()
Dim temp
ReDim RndNum(1 To 10)
For NN = 1 To 10
RndNum(NN) = Rnd
Next NN
With Application
temp = .Match(.Small(RndNum, [ROW(1:10)]), RndNum, 0)
temp(.Match(10, temp, 0), 1) = 0
End With
getRandOrder = temp
End Function
（半平太） 2017/02/28(火) 08:08
簡単に、Sheet2上にボタンを作って、
Sub ボタン1_Click()
Dim s As Single
s = Timer
Randomize
Do
Range("A1").Value = WorksheetFunction.RandBetween(1, 9999)
Loop Until Timer - s > 3
Range("A1").Value = Worksheets("Sheet1").Range("E2").Value
End Sub
Sheet2のA1の4ケタの数字を変化させて最後にSheet1のE2の値を表示するだけとか。
（ウッシ） 2017/02/28(火) 08:16
マナさんのコードをいただいて、図形を回転させながら処理してみました。
シートに１つ、好きな図形を配置してください。 星 6 あたりが、もっともらしく見えます。 背景色や文字色や、文字の場所、大きさ 等は、好きなように設定してください。 図形や文字に3D効果を設定しておけば、さらにもっともらしく見えるかもしれません。
以下のコードを標準モジュールに貼り付けて、この図形にマクロ登録し、クリックしてみてください。
Sub いんちき抽選()
Dim s As Single
Dim sp As Shape
Dim x As Long
Set sp = ActiveSheet.Shapes(Application.Caller)
s = Timer
Randomize
Do
x = IIf(x = 360, 0, x + 1)
sp.Rotation = x
sp.DrawingObject.Text = WorksheetFunction.RandBetween(1, 9999)
DoEvents
Loop Until Timer - s > 3
sp.DrawingObject.Text = Sheets("Sheet1").Range("E1").Value
sp.Rotation = 0
End Sub
（β） 2017/02/28(火) 08:58
↑
x = IIf(x = 360, 0, x + 1)
これを
x = IIf(x > 360, 0, x + 2) や x = IIf(x > 360, 0, x + 3)
あたりにすると、早く回転します。
（β） 2017/02/28(火) 09:09
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.