GO BACK

●2003-06号●　Excel計算で家を買おう！

今回は、セルに記述して使う関数や計算式をマクロ内から利用するための方法についてです。その例として、家購入のローン計算シートを作成し、これを 利用したフォームを作成してみます。

［リスト１］
Private Sub CalcBtn_Click()
  With Sheets("Loan")
    .Cells(2, 2) = TextBox1.Text
    .Cells(3, 2) = TextBox2.Text
    .Cells(5, 2) = TextBox4.Text / 100
    .Cells(6, 2) = TextBox5.Text
    Calculate
    TextBox3.Text = .Cells(4, 2)
    TextBox6.Text = Int(.Cells(8, 2))
    TextBox7.Text = Int(.Cells(9, 2) / 10000)
    TextBox8.Text = Int(.Cells(10, 2) / 10000)
  End With
End Sub

［リスト２］
Sub showCalc()
UserForm1.Show
End Sub

今回は、ExcelのVBAからWSHオブジェクトを使う方法についてです。参照設定の仕方、主要オブジェクトであるWshShellと FileSystemObjectの基本的な利用についてまとめます。

［リスト１］
Sub CheckMyDoc()
  Set ob = New WshShell
  mydoc = ob.SpecialFolders("MyDocuments")
  Set fs = New FileSystemObject
  Set myobj = fs.GetFolder(mydoc)
  With ActiveSheet
    .Cells.Clear
    .Cells(1, 1) = "ファイル名"
    .Cells(1, 2) = "ショート名"
    .Cells(1, 3) = "サイズ"
    .Cells(1, 4) = "作成日"
    .Cells(1, 5) = "修正日"
    i = 2
    For Each fpath In myobj.Files
      Set obj = fs.GetFile(fpath)
      .Cells(i, 1) = obj.Name
      .Cells(i, 2) = obj.ShortName
      .Cells(i, 3) = obj.Size
      .Cells(i, 4) = obj.DateCreated
      .Cells(i, 5) = obj.DateLastModified
      i = i + 1
    Next
  End With
End Sub

［リスト２］−−変数moveToを書き換えて使う
Sub MoveFiles()
  Set ob = New WshShell
  mydoc = ob.SpecialFolders("MyDocuments")
  moveTo = mydoc & "\backup\"
  Set fs = New FileSystemObject
  For Each obj In Selection.Rows
    fname = obj.Cells(1).Value
    fs.MoveFile mydoc & "\" & fname, moveTo
  Next
  CheckMyDoc
End Sub

［リスト３］
Sub DelFiles()
  Set ob = New WshShell
  mydoc = ob.SpecialFolders("MyDocuments")
  Set fs = New FileSystemObject
  For Each obj In Selection.Rows
    fname = obj.Cells(1).Value
    fs.DeleteFile mydoc & "\" & fname
  Next
  CheckMyDoc
End Sub

［リスト４］−−※各ボタン用マクロ
Private Sub listBtn_Click()
  ThisWorkbook.CheckMyDoc
End Sub

Private Sub DelBtn_Click()
  ThisWorkbook.DelFiles
End Sub

Private Sub MoveBtn_Click()
  ThisWorkbook.MoveFiles
End Sub

今回は、昔ながらの数学シミュレーション「ライフ」をエクセルで作ってみる。一定時間ごとにマクロが自動呼び出しされるテクなどを使っている。

［リスト１］−−OnOffBtnのコード
Private Sub OnOffBtn_Click()
  If ActiveCell = "●" Then ActiveCell = "" Else ActiveCell = "●"
End Sub

［リスト２］−−CheckDoのコード
Private Sub CheckDo_Change()
  If CheckDo.Value = True Then Application.OnTime Now + TimeValue("00:00:01"), "Sheet1.doLife"
End Sub

［リスト３］−−メイン部分
Sub doLife()
  Dim data(20, 20) As String
  For i = 1 To 20
    For j = 1 To 20
      n0 = 0
      If Cells(i, j) = "●" Then n0 = 1
      n = 0
      If i > 1 Then
        If j > 1 Then If Cells(i - 1, j - 1) = "●" Then n = n + 1
        If Cells(i - 1, j) = "●" Then n = n + 1
        If j < 20 Then If Cells(i - 1, j + 1) = "●" Then n = n + 1
      End If
      If j > 1 Then If Cells(i, j - 1) = "●" Then n = n + 1
      If j < 20 Then If Cells(i, j + 1) = "●" Then n = n + 1
      If i < 20 Then
        If j > 1 Then If Cells(i + 1, j - 1) = "●" Then n = n + 1
        If Cells(i + 1, j) = "●" Then n = n + 1
        If j < 20 Then If Cells(i + 1, j + 1) = "●" Then n = n + 1
      End If
      n1 = ""
      If n0 = 1 Then If (n = 2 Or n = 3) Then n1 = "●"
      If n0 = 0 Then If n = 3 Then n1 = "●"
      data(i, j) = n1
    Next
  Next
  For i = 1 To 20
    For j = 1 To 20
      Cells(i, j) = data(i, j)
    Next
  Next
  If CheckDo.Value = True Then Application.OnTime Now + TimeValue("00:00:01"), "Sheet1.doLife"
End Sub

今回は、Windowsユーザなら誰しも知っている「マインスイーパ」をエクセルで作ってみました。といっても、完全版ではないですが、一応遊べま す。

［リスト１］
Dim flg As Boolean
Dim data(12, 12) As Integer

Sub doCheck()
  x = ActiveCell.Row
  y = ActiveCell.Column
  If Cells(x, y) = "" Then Cells(x, y) = check(x, y)
End Sub

Function check(x, y)
  If x < 2 Or x > 11 Or y < 2 Or y > 11 Or Cells(x, y) <> "" Then Exit Function
  If data(x, y) = 1 Then
  flg = False
  For i = 2 To 11: For j = 2 To 11
  If data(i, j)=1 Then Cells(i, j)="★"
  Next: Next: MsgBox "GAME OVER"
  Else: n = 0
  If data(x - 1, y - 1) = 1 Then n = n + 1
  If data(x - 1, y) = 1 Then n = n + 1
  If data(x - 1, y + 1) = 1 Then n = n + 1
  If data(x, y - 1) = 1 Then n = n + 1
  If data(x, y + 1) = 1 Then n = n + 1
  If data(x + 1, y - 1) = 1 Then n = n + 1
  If data(x + 1, y) = 1 Then n = n + 1
  If data(x + 1, y + 1) = 1 Then n = n + 1
  check = n
  If n = 0 Then
  Cells(x, y) = 0: check x - 1, y - 1
  check x - 1, y: check x - 1, y + 1
  check x, y - 1: check x, y + 1
  check x + 1, y - 1: check x + 1, y
  check x + 1, y + 1
  End If: End If
End Function

Private Sub StartBtn_Click()
  Cells(1, 1).Select
  For i = 1 To 12: For j = 1 To 12
  data(i, j) = 0: Cells(i, j) = ""
  Next: Next
  For i = 1 To 15
  x = Int(Rnd() * 10) + 2
  y = Int(Rnd() * 10) + 2
  data(x, y) = 1: Next
  MsgBox "ゲーム開始です！": flg = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If flg = False Then Exit Sub
  doCheck
End Sub

今回は、学習型のしりとりです。テキストを処理して遊ぶということの基本を考えていきます。

［リスト１］
Dim last
Sub Shiritori()
Sheets("Used").Cells.Clear: flg = False:
last = "": res = "ゲーム開始！"
Do
str1 = InputBox(res & vbCrLf & "あなたの答えは？")
If str1 = "" Then
MsgBox "あなたの負けです。"
Exit Sub: End If
a = CheckChar(Left(str1, 1))
b = CheckChar(Right(last, 1))
If last <> "" And CheckChar(Left(str1, 1)) <> CheckChar(Right(last, 1)) Then
MsgBox "しりとりになってませんよ。あなたの負けです。"
Exit Sub: End If
n = CheckChar(str1)
If n = -2 Then
MsgBox "ごめんなさい、言葉がわかりません。ひらがな・カタカナで入力してください。"
Exit Sub: End If
If n = -1 Then
MsgBox "最後が「ん」です。あなたの負けです。"
Exit Sub: End If
re = CheckAnswer(str1, n)
If re = -1 Then
MsgBox "「" & str1 & "」は、もう使いました。あなたの負けです。"
Exit Sub
Else
str2 = str1: c = Right(str2, 1)
If c = "ー" Then str2 = Left(str1, (Len(str1) - 1))
res = GetAnswer(str2): last = res
If res = "" Then
res="・・・思いつきません。私の負けです。"
flg = True: End If
If flg = True Then
MsgBox res: Exit Sub
Else: res="私：　" & res & vbCrLf: End If
End If: Loop: End Sub
Function CheckChar(ByVal ans As String) As Integer
m = Left(ans, 1): m2 = Right(ans, 1)
res = -2
If m2 = "ん" Or m2 = "ン" Then
CheckChar = -1: Exit Function: End If
With Sheets("50音")
For i = 1 To 5: For j = 1 To 15
n = .Cells(j, i): n2 = .Cells(j, i + 5)
n3 = .Cells(j,i+10): n4=.Cells(j,i+15)
If n = m Or n2 = m Or n3 = m Or n4 = m Then res = i + (j - 1) * 5
Next: Next
End With: CheckChar = res
End Function
Function CheckAnswer(ByVal ans As String, ByVal cnum As Integer) As Integer
n = Sheets("Data").Columns(cnum)
For i = 1 To 100
str1 = Sheets("Data").Cells(i, cnum)
If str1 = ans Then
If Sheets("Used").Cells(i, cnum) = "" Then
Sheets("Used").Cells(i, cnum) = 1
CheckAnswer = 0
Else: CheckAnswer = -1: End If
Exit Function: End If
If Sheets("Data").Cells(i, cnum) = "" Then
Sheets("Used").Cells(i, cnum) = 1
Sheets("Data").Cells(i, cnum) = ans
CheckAnswer = 0
Exit Function: End If
Next: CheckAnswer = 1
End Function
Function GetAnswer(ByVal ans) As String
m = Right(ans, 1): cnum = CheckChar(m)
For i = 1 To 100
str1 = Sheets("Used").Cells(i, cnum)
If str1 = "" Then
Sheets("Used").Cells(i, cnum) = 1
GetAnswer = Sheets("Data").Cells(i, cnum)
Exit Function: End If
Next: GetAnswer = ""
End Function

今回は、２次元のゲーム盤を使った一人遊びのゲーム「ソリティア」を作ります。ペグの処理などの基本を考えていきます。

［リスト１］
Dim lastX, lastY, flag

Sub StartBtn_Click()
  lastX = 1
  lastY = 1
  Cells(lastX, lastY).Select
  For i = 1 To 9
    For j = 1 To 6
      Cells(i, j) = ""
    Next
  Next
  For i = 4 To 6
    For j = 1 To 9
      Cells(i, j) = "●"
      Cells(j, i) = "●"
    Next
  Next
  Cells(5, 5) = "・"
  flag = True
End Sub

Private Sub Worksheet_SelectionChange _
    (ByVal Target As Range)
  If flag = False Then Exit Sub
  x = ActiveCell.Row
  y = ActiveCell.Column
  If Cells(x, y) <> "" Then
    If Cells(x, y) = "・" And _
        Cells(lastX, lastY) = "●" And _
        Cells((lastX + x) / 2, _
        (lastY + y) / 2) = "●" And _
        ((Abs(lastX - x) = 2 Or _
        (Abs(lastX - x) = 0)) And _
        (Abs(lastY - y) = 0 Or _
        Abs(lastY - y) = 2)) Then
      Cells(lastX, lastY) = "・"
      Cells((lastX + x) / 2, _
        (lastY + y) / 2) = "・"
      Cells(x, y) = "●"
      CheckEnd
    End If
    lastX = x
    lastY = y
  End If
End Sub

Sub CheckEnd()
  n = 0
  For i = 1 To 9
    For j = 1 To 9
      If Cells(i, j) = "●" Then n = n + 1
    Next
  Next
  If n = 1 Then
    flag = False
    MsgBox "Game Clear!"
  End If
End Sub

今回は、セルの色を変更することでグラフィックを作成する例を考えてみます。一例として、迷路を自動生成するマクロを造ってみます。

［リスト１］
Dim MazeColor As Integer

Sub MakeMaze()
  MazeColor = 3 '★迷路の色
  Max = 51  '★奇数にする
  Range(Cells(1, 1), Cells(Max, Max)).Clear
  For i = 1 To Max
    Rows(i).RowHeight = 10
    Cells(i, 1).Interior.ColorIndex = MazeColor
    Cells(i, Max).Interior.ColorIndex = MazeColor
  Next
   For i = 1 To Max
    Columns(i).ColumnWidth = 1
    Cells(1, i).Interior.ColorIndex = MazeColor
    Cells(Max, i).Interior.ColorIndex = MazeColor
  Next
  For i = 1 To Max * Max
    x = Int(Rnd * Max / 2) * 2 + 1
    y = Int(Rnd * Max / 2) * 2 + 1
    d = Int(Rnd * 4)
    Select Case (d)
      Case 0:
        ax = 1
        ay = 0
      Case 1:
        ax = -1
        ay = 0
      Case 2:
        ax = 0
        ay = 1
      Case 3:
        ax = 0
        ay = -1
    End Select
    If Cells(x, y).Interior.ColorIndex <> MazeColor Then
      If GetNearCells(x, y) = 0 Then
        n = Int(Rnd * Max)
        For j = 0 To n
          Cells(x, y).Interior.ColorIndex = MazeColor
          x = x + ax
          y = y + ay
          If GetNearCells(x, y) > 1 Then
            Cells(x, y).Interior.ColorIndex = MazeColor
            Exit For
          End If
        Next
      End If
    End If
  Next
End Sub

Function GetNearCells(x, y)
  n = 0
  If Cells(x - 1, y - 1).Interior.ColorIndex = MazeColor Then n = n + 1
  If Cells(x, y - 1).Interior.ColorIndex = MazeColor Then n = n + 1
  If Cells(x + 1, y - 1).Interior.ColorIndex = MazeColor Then n = n + 1
  If Cells(x - 1, y).Interior.ColorIndex = MazeColor Then n = n + 1
  If Cells(x + 1, y).Interior.ColorIndex = MazeColor Then n = n + 1
  If Cells(x - 1, y + 1).Interior.ColorIndex = MazeColor Then n = n + 1
  If Cells(x, y + 1).Interior.ColorIndex = MazeColor Then n = n + 1
  If Cells(x + 1, y + 1).Interior.ColorIndex = MazeColor Then n = n + 1
  GetNearCells = n
End Function

[リスト２]
Private Sub CommandButton1_Click()
  MakeMaze
End Sub

今回は、エクセルをテキストベースのエディタ代わりに使う例として、バイナリエディタを作成してみます。今回はスクリプトだけではうまく機能しない ので、ちゃんと記事を読んで下さいね。

［リスト１］
Sub readBtn_Click()
  FilePath = Application.GetOpenFilename()
  If FilePath = False Then Exit Sub
  Dim data(15) As Byte
  Open FilePath For Binary Access Read As #1
  FLen = LOF(1)
  For i = 0 To (FLen \ 16) - 1
    Get #1, , data
    For j = 0 To 15
      str1 = Hex(data(j))
      If Len(str1) < 2 Then str1 = "0" & str1
      Cells(i + 1, j + 1) = str1
    Next
  Next
  amari = FLen Mod 16
  Dim data2() As Byte
  ReDim data2(amari)
  Get #1, , data
  For i = 0 To (amari - 1)
    str1 = Hex(data(i))
    If Len(str1) < 2 Then str1 = "0" & str1
    Cells(FLen \ 16 + 1, i + 1) = str1
  Next
  Close #1
End Sub

Sub writeBtn_Click()
  FilePath = Application.GetSaveAsFilename()
  If FilePath = False Then Exit Sub
  Open FilePath For Binary Access Write Lock Write As #1
  n = 1
  Dim data As Byte
  Do
    For i = 1 To 16
      str1 = Cells(n, i).Value
      If str1 = "" Then
        Close #1
        Exit Sub
      End If
      data = Val("&H" & str1)
      Put #1, , data
    Next
    n = n + 1
  Loop
End Sub

Sub clearBtn_Click()
  Cells.ClearContents
End Sub

今回は、エクセルで「さめがめ」などのパズルゲームの基礎を作っています。一応、遊べる程度にはなってます。ただしハイスコアなどはついていません のでご了解を。

［リスト１］
Dim w, h As Integer

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  c1 = Target.Column
  r1 = Target.Row
  n1 = Cells(r1, c1).Interior.ColorIndex
  If n1 < 3 Then Exit Sub
  If GetCNum(r1, c1, n1) > 1 Then CheckCell r1, c1, n1
  DownCells
End Sub

Function GetCNum(ByVal r, ByVal c, ByVal n)
  GetCNum = 1
  If r > 1 Then If Cells(r - 1, c).Interior.ColorIndex = n Then GetCNum = GetCNum + 1
  If r < h Then If Cells(r + 1, c).Interior.ColorIndex = n Then GetCNum = GetCNum + 1
  If c > 1 Then If Cells(r, c - 1).Interior.ColorIndex = n Then GetCNum = GetCNum + 1
  If c < w Then If Cells(r, c + 1).Interior.ColorIndex = n Then GetCNum = GetCNum + 1
End Function

Sub CheckCell(ByVal r, ByVal c, ByVal n)
  If r <= 0 Or r > h Or c <= 0 Or c > w Then Exit Sub
  If Cells(r, c).Interior.ColorIndex <> n Then Exit Sub
  Cells(r, c).Interior.ColorIndex = 1
  CheckCell r - 1, c, n
  CheckCell r + 1, c, n
  CheckCell r, c - 1, n
  CheckCell r, c + 1, n
End Sub

Sub DownCells()
  n = -1
  While (n <> 0)
    n = 0
    For i = 1 To w
      For j = h To 2 Step -1
        If Cells(j, i).Interior.ColorIndex = 1 Then
          If Cells(j - 1, i).Interior.ColorIndex <> 1 Then
            c = Cells(j - 1, i).Interior.ColorIndex
            Cells(j, i).Interior.ColorIndex = c
            Cells(j - 1, i).Interior.ColorIndex = 1
            n = n + 1
          End If
        End If
      Next
    Next
  Wend
End Sub

Sub Initial()
  w = 20: h = 20
  For i = 1 To w
    For j = 1 To h
      Cells(i, j).Interior.ColorIndex = Int(Rnd() * 6) + 3
    Next
  Next
End Sub

今回は、多角形や曲線などの複雑なシェイプを作って幾何学図形を作成してみます。その昔、グルグル回転させてお花模様を描いたりした定規がありませ んでした？　ああいった図形を自動生成させてみます。

［リスト１］
Private Sub drawBtn_Click()
  n = Cells(1, 2)
  n1 = Cells(1, 3)
  n2 = Cells(1, 4)
  w = Cells(2, 2) / 2
  h = Cells(3, 2) / 2
  x1 = Cells(4, 2) + w
  y1 = Cells(5, 2) + h
  lw = Cells(6, 2)
  Pi = 3.14159
  If n Mod n1 = 0 Then
    n = n + 1
    Cells(1, 2) = n
  End If
  ds = Pi * 2 / n * (CInt(n / n1 * n2))
  x = Sin(d) * w
  y = Cos(d) * h
  With Shapes.BuildFreeform(msoEditingAuto, x + x1, y + y1)
    For i = 1 To n + 1
      x = Sin(ds * i) * w
      y = Cos(ds * i) * h
      .AddNodes msoSegmentCurve, msoEditingAuto, x + x1, y + y1
    Next
    With .ConvertToShape
      .Line.ForeColor.RGB = RGB(255, 0, 0)
      .Line.Weight = lw
      .Fill.Visible = msoFalse
    End With
  End With
End Sub

Private Sub delBtn_Click()
  n = Shapes.Count
  If n <= 2 Then Exit Sub
  Shapes.Item(n).Delete
End Sub

［リスト２］
Sub changeLieWidth()
  n = Shapes.Count
  If n <= 2 Then Exit Sub
  Shapes.Item(n).Line.Weight = Cells(6, 2)
End Sub

Sub changeFillMode()
  n = Shapes.Count
  If n <= 2 Then Exit Sub
  With Shapes.Item(n).Fill
  If .Visible = msoTrue Then
    .Visible = msoFalse
  Else
    .Visible = msoTrue
  End If
  End With
End Sub