スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excel VBA をやってみた その9 


そろそろ広告表示されるタイミングかと・・・
急遽、見かけた質問をチョッとやってみた


100マス計算のシートを作ってみる。
その時、1桁部分を2桁にしたい・・・・
ただ・・・ "X" の場合は、2桁x1桁にしたい・・・・

10×10 のセルを使って(正確には 11 x 11 )、"+","-","X" での計算を埋め込めるように
そして、
・計算元の値の桁を指定できるように
・正解も付加する/しないを指定できるように
・また、正解を付加した場合、間違った結果を入力したら「文字色」を赤に(条件付き書式にて)

"+", "X" では違和感はないのですが、"-" の場合は「上」の値 -「左」の値 なんですね・・・
「左」-「上」の方が私はしっくりきますね・・・
でもまぁ、そういうものらしいので・・・・

Private Sub MakeMasu(sPos As String, sPtn As String _
    , Optional iXcnt As Long = 10, Optional iXketa As Long = 2 _
    , Optional iYcnt As Long = 10, Optional iYketa As Long = 2 _
    , Optional bAns As Boolean = True _
    , Optional bSgn As Boolean = False)
という関数を作って

「B2」の所に、"+" の 10×10マスを作成し、その右側に正解の表を付加する場合
  Call MakeMasu("B2", "+")
の様に呼び出すだけです。

明示指定していない部分は、
iXcnt : 列側マス数 (=10)
iXketa : 列側数値の桁数 (=2)
iYcnt : 行側マス数 (=10)
iYketa : 行側数値の桁数 (=2)
bAns : 正解表を付加するか (=はい)
bSgn : 数値に負値を含めるか (=いいえ)

※ ()内は省略した時の解釈値

また、例えば
  Call MakeMasu("B2", "+", 11, 3, 15, 2, True, True)
と呼び出すと

列側マス数 : 11
列側数値の桁数 : 3
行側マス数 : 15
行側数値の桁数 : 2
正解表を付加するか : はい
数値に負値を含めるか : はい

で作成します。
そこで、
Const CTASU As String = "+"
Const CHIKU As String = "-"
Const CKAKE As String = "X"

Public Sub Sample1()
  Application.ScreenUpdating = False
  ActiveSheet.UsedRange.EntireRow.Delete
  Call MakeMasu("B2", CTASU)
  Call MakeMasu("B14", CHIKU)
  Call MakeMasu("B26", CKAKE, iXketa:=1, iYketa:=1)
  Call MakeMasu("B38", CKAKE, iXketa:=1)
  Call MakeMasu("B50", CKAKE, iYketa:=1, bAns:=False)
  Call MakeMasu("B62", CTASU, iXketa:=3, bSgn:=True)
  Application.ScreenUpdating = True
End Sub
としたとすると以下の様になります。(縦にスクロール)

kEnt187_1A  kEnt187_1B

Public Sub Sample2()
  Application.ScreenUpdating = False
  ActiveSheet.UsedRange.EntireRow.Delete
  Call MakeMasu("B4", CTASU, 11, 3, 15, 2, True, True)
  Application.ScreenUpdating = True
End Sub
としたとすると以下の様になります。(横にスクロール)

kEnt187_2A  kEnt187_2B

で、正解表を作成しているので、間違った入力部分は「赤」表示されます。

kEnt187_2C

※ "-" の場合、結果が 正 だけにはなりません。( 63 - 96 があったりします)
 それ用のものが必要なら、上限値 / 下限値を指定する様に変更していけば良いと思います。
 
まずは、記述してみたのは以下(Excel2007 にて)
Option Explicit

Const CTASU As String = "+"
Const CHIKU As String = "-"
Const CKAKE As String = "X"

Private Function MakeNumAry(iCnt As Long, iKeta As Long _
            , Optional bSgn As Boolean = False) As Variant
  Dim vAry() As Variant
  Dim iW() As Long
  Dim i As Long, j As Long

  ReDim vAry(iCnt - 1)
  j = 10 ^ iKeta - 10 ^ (iKeta - 1) - 1
  If (j < iCnt - 1) Then j = iCnt - 1
  ReDim iW(j)
  j = 10 ^ (iKeta - 1)
  If (j = 1) Then j = 0
  For i = 0 To UBound(iW)
    iW(i) = j + i
  Next

  Randomize

  For i = 0 To UBound(vAry)
    j = Int((UBound(iW) - i + 1) * Rnd())
    vAry(i) = iW(j)
    If (bSgn) Then
      If (Rnd() > 0.9) Then vAry(i) = -vAry(i)
    End If
    iW(j) = iW(UBound(iW) - i)
  Next

  MakeNumAry = vAry
End Function

Private Sub ShowLine(sPos As String, iXcnt As Long, iYcnt As Long)
  Dim v As Variant

  With Range(sPos)
    With .Resize(iYcnt + 1, iXcnt + 1)
      .Borders.LineStyle = xlContinuous
      For Each v In Array(xlEdgeBottom, xlEdgeLeft, xlEdgeRight, xlEdgeTop)
        .Borders(v).Weight = xlThick
      Next
    End With
    .Resize(, iXcnt + 1).Borders(xlEdgeBottom).Weight = xlThick
    .Resize(iYcnt + 1).Borders(xlEdgeRight).Weight = xlThick
  End With
End Sub

Private Sub MakeMasu(sPos As String, sPtn As String _
    , Optional iXcnt As Long = 10, Optional iXketa As Long = 2 _
    , Optional iYcnt As Long = 10, Optional iYketa As Long = 2 _
    , Optional bAns As Boolean = True _
    , Optional bSgn As Boolean = False)

  Dim sS As String
  Dim r As Range

  With Range(sPos)
    .Value = sPtn
    .Offset(, 1).Resize(, iXcnt) = MakeNumAry(iXcnt, iXketa, bSgn)
    .Offset(1).Resize(iYcnt) = WorksheetFunction.Transpose(MakeNumAry(iYcnt, iYketa, bSgn))
    Call ShowLine(sPos, iXcnt, iYcnt)
    With .Resize(iYcnt + 1, iXcnt + 1)
      .HorizontalAlignment = xlHAlignCenter
      .VerticalAlignment = xlVAlignCenter
      .EntireColumn.ColumnWidth = 8.5
      .EntireRow.RowHeight = 26
      .Font.Size = 18
    End With
    If (bAns) Then
      .Resize(iYcnt + 1, iXcnt + 1).Copy .Offset(, iXcnt + 2)
      With .Offset(, iXcnt + 2)
        sS = "=R" & .Row & "C" & "★RC" & .Column
        Select Case sPtn
          Case CTASU: sS = Replace(sS, "★", "+")
          Case CHIKU: sS = Replace(sS, "★", "-")
          Case CKAKE: sS = Replace(sS, "★", "*")
        End Select
        .Offset(1, 1).Resize(iYcnt, iXcnt).FormulaR1C1 = sS
        .Resize(iYcnt + 1, iXcnt + 1).EntireColumn.ColumnWidth = 8.5
      End With
      For Each r In .Offset(1, 1).Resize(iYcnt, iXcnt)
        With r.FormatConditions.Add(xlCellValue, xlNotEqual, "=" & r.Offset(, iXcnt + 2).Address)
          .Font.Color = RGB(255, 0, 0)
        End With
      Next
    End If
  End With
End Sub

Public Sub Sample1()
  Application.ScreenUpdating = False
  ActiveSheet.UsedRange.EntireRow.Delete
  Call MakeMasu("B2", CTASU)
  Call MakeMasu("B14", CHIKU)
  Call MakeMasu("B26", CKAKE, iXketa:=1, iYketa:=1)
  Call MakeMasu("B38", CKAKE, iXketa:=1)
  Call MakeMasu("B50", CKAKE, iYketa:=1, bAns:=False)
  Call MakeMasu("B62", CTASU, iXketa:=3, bSgn:=True)
  Application.ScreenUpdating = True
End Sub

Public Sub Sample2()
  Application.ScreenUpdating = False
  ActiveSheet.UsedRange.EntireRow.Delete
  Call MakeMasu("B4", CTASU, 11, 3, 15, 2, True, True)
  Application.ScreenUpdating = True
End Sub

 
処理メインの MakeMasu でやっている事を解説してみると、

・指定された場所を With Range(sPos) で固定してから
・指定された "+","-","X" を埋め込み
 ※ "+","-","X" の指定/解釈で、半角/全角間違わない様に Const 宣言したもので・・・
・列側/行側に、指定された桁/マス数で値を設定
・罫線を引く
・文字の配置 / セルの大きさ / 文字の大きさを設定
※ 正解表の作成が無ければここまでで終了

正解表を作る指定( bAns = True )だったら
・今作った表部分を .Offset(, iXcnt + 2) の所にコピー
・コピーした方の内部に、計算式の埋め込み
 ※ 「上」参照では行固定、「左」参照では列固定 とした扱いに・・・
・コピーできなかったセルの幅を同様に設定
 ※ コピーでは、文字の配置 / 罫線情報 は同じものになるみたい
・元の表部分に条件付き書式を設定
 ※ セルの値が正解表のものと違ったら、文字の色を赤に

・・・ってな感じになります。

何桁の数値で何個・・・・
この処理をしている関数 MakeNumAry についても触れておきます。
引数は、何個、何桁、負値の有無 の3つになります。
指定された個数の値を求める時に、重複したものは選ばないことを念頭に置いてます。

乱数 Rnd() を使って1つ1つ求めて、今求めたものは以前に求めていた・・・
随時確認しながら処理を進める・・・ってことでも良いのですが・・・
例えば、1桁で10個を考えた時、0~9を抜けなくバラバラに抽出・・・・
10回の処理では終わらないんでしょうかね・・・
Int(Rnd() * 10) ですると、0~9が得られますが、何回かは同じ値を抽出するんでしょう・・・・
10回で処理を終わるためには、1度抽出したものは次回の抽出で除外してやれば・・・
この辺は、過去記事「Excel VBA をやってみた その8」でも触れていましたね・・・
抽出数値候補を配列で作っておいて、そこから抜き出す様に・・・
4桁指定されても1秒かからないから・・・いいか(メモリは食うけど)

  ReDim vAry(iCnt - 1)
で、戻す配列を作って・・・(配列は 0 スタートなので、個数 - 1 にて)
  j = 10 ^ iKeta - 10 ^ (iKeta - 1) - 1
  If (j < iCnt - 1) Then j = iCnt - 1
  ReDim iW(j)
で対象数値を格納する配列を確保します。
桁が =3 の場合、j = 10 ^ 3 - 10 ^ 2 - 1 = 1000 - 100 - 1 = 899
3桁の数値は、100 ~ 999 なので、0 スタートの最大 899 で良いですよね・・・
その下の If (j < iCnt - 1) Then j = iCnt - 1 は何をやっているかですが、
桁が =1 だった場合、j = 10 ^ 1 - 10 ^ 0 - 1 = 10 - 1 - 1 = 8 となるんですね
なので、桁=1 の場合を補正するものになります。
  j = 10 ^ (iKeta - 1)
  If (j = 1) Then j = 0
  For i = 0 To UBound(iW)
    iW(i) = j + i
  Next
ここの部分は、
j に桁の初めの数値を設定しておきます。
桁が =3 の場合、j = 10 ^ 2 = 100
桁が =1 の場合、j = 10 ^ 0 = 1 となるので、If (j = 1) Then j = 0 で 0 に補正
で、配列に対象数値全部作成しておきます。

  For i = 0 To UBound(vAry)
    j = Int((UBound(iW) - i + 1) * Rnd())
    vAry(i) = iW(j)
    If (bSgn) Then
      If (Rnd() > 0.9) Then vAry(i) = -vAry(i)
    End If
    iW(j) = iW(UBound(iW) - i)
  Next
で、抽出 / 負値指定の処理 / 再度抽出されない様に有効範囲最後の値で埋め込み・・・・
ってな感じですね・・・・
※ ここでの処理は、指定された個数 / 桁は正しいものとして動きます。
※ もし、個数 > 10 で、桁 = 1 なら・・・・
  対象数値を作成する時、
  0 スタートで確保した配列分数値を埋め込むので 2 桁の数値が埋まる事になります。
※ やり方はいろいろあるかもしれません。
 例えば、用意した 10 個を使いきったら、また 10 個用意してから抽出を続ける・・・
 面倒なので・・・・個数 / 桁 は正しく指定するってことで・・・

この関数での余談になりますが、
同じ値を再抽出する事があっても、必要な個数分得られるまで処理を繰り返す
(重複したものを除外しないので、時間はかかる様になるけど・・・)
(最悪、無限ループ???)
でよければ、以下の様な記述もあります。
Private Function MakeNumAry(iCnt As Long, iKeta As Long _
            , Optional bSgn As Boolean = False) As Variant
  Dim j As Long, k As Long

  Randomize

  k = 10 ^ (iKeta - 1)
  With CreateObject("Scripting.Dictionary")
    While (.Count < iCnt)
      j = 0
      Do While ((j \ k) = 0)
        j = j * 10
        j = j + Int(Rnd() * 10)
        If (iKeta = 1) Then Exit Do
      Loop
      If (bSgn) Then
        If (Rnd() > 0.9) Then j = -j
      End If
      .Item(j) = Null
    Wend
    MakeNumAry = .Keys
  End With
End Function
結構お気に入りの Dictionary を使って、値をキーとして登録して、個数分グルグル回る・・・

※ ただし、個数 > 10 かつ 桁 = 1 の場合、確実に無限ループになります。
 (個数 > 90 かつ 桁 = 2 の場合も同様ですが・・・)
 無限ループを回避する為に、
 ・引数をチェック
 ・While (.Count < iCnt) 部分に、実行回数用変数を設けて 10000 回とか回ったらエラーに・・・
 するとか・・・

また、
      j = 0
      Do While ((j \ k) = 0)
        j = j * 10
        j = j + Int(Rnd() * 10)
        If (iKeta = 1) Then Exit Do
      Loop
部分では、直接必要な桁を求めても良いと思います。

うんうん・・・・
一度記述してみた後、眺め直すんですが・・・ まぁ・・今回はこの記述で良いか・・・
ってなことが多々あります。
今回での記述で言えば、
        sS = "=R" & .Row & "C" & "★RC" & .Column
        Select Case sPtn
          Case CTASU: sS = Replace(sS, "★", "+")
          Case CHIKU: sS = Replace(sS, "★", "-")
          Case CKAKE: sS = Replace(sS, "★", "*")
        End Select
部分は、
        Select Case sPtn
          Case CTASU: sS = "+"
          Case CHIKU: sS = "-"
          Case CKAKE: sS = "*"
        End Select
        sS = "=R" & .Row & "C" & sS & "RC" & .Column
でも同じ結果になりますね・・・・
Replace 関数を使わない分、少しは速くなるんでしょうか???
(というか、今回はわざと逆にしてみました:こういう書き方もできるかな・・・・ってことで)
本当に Replace を使った書き方にしていたのなら
sS = "=R" & .Row & "C" & "★RC" & .Column

sS = "=R" & .Row & "C★RC" & .Column
としていたと思います。(変更しきれていなかった・・・という事になりますかね)

後は、引数を持たせる部分では・・・
マス数は 10 が大半で・・・・っていう事を想定した記述もしています。
また、上記の Case 文もそうですね・・・ Case Else は書いておいた方が良いんでしょうかね・・・
売り物を作る時には注意すべき点ではありますね・・・・


今回、サンプルファイルはありません。
必要ならコメント頂ければと・・・・

上記 VBA を標準モジュールに転記して「Sample1」「Sample2」を実行すれば・・・・
そこそこ動くかと・・・・
関連記事

2013/12/10

Category: やってみる

TB: --  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。