日々の破片

_ Excelいじり

なんか、えらく面倒なExcelのお絵かきが必要になって、それは四角の中にテキストを入れて、場合によってはその四角に別の四角がくっついて（しかも、それにもテキストがある）いて、しかも全部で四角が200個くらいある。

それだけあると、人間がうまいこと並べてやらなければだめだが、かといってすべて手作業するのはいやなこった。というわけで、あまり気はすすまないが、マクロを使って、別のシートの表に埋まっているテキストを取り出して四角を配置しておくものを作った。

が、ときどきうまく動き、ときどきうまく動かない。

'思い出して書いているので嘘もあるはず。
Set src = WorkSheets(4)   ' Setを忘れやすい
Set dst = WorkSheets(5)
x = 100
y = 200
For r = 10 To 300
  If src.Range("F" & r).Value = "" Then
    Exit For  ' カラムFが空なら終了
  End If
  If src.Range("G" & r).Value <> "" Then
    Set attr = dst.Shapes.AddShape(msoShapeRectangle, x, y - 24, 240, 12)
    With attr.TextFrame
      .Characters.Text = src.Range("G" & r).Value
      .Characters.Font.Size = 11
    End With
  Else
    Set attr = Nothing
  End If
  Set rc = dst.Shapes.AddShape(msoShapeRectangle, x, y, 240, 40)
  x = x + 260
  y = y + 80
  With rc.TextFrame
    .Characters.Text = src.Range("F" & r).Value
    .Characters.Font.Size = 12
  End With
  If Not attr Is Nothing Then
    attr.Select True   ' 以前の選択をちゃらにする
    rc.Select False    ' 現在の選択に追加
    Selection.ShapeRange.Group ' 2つ四角を作った場合はグループ化
  End If
Next

良くわかったが、MSDNのOffice2003のドキュメントがかすなのは、コレクション、オブジェクト、メソッド、プロパティという項目立てになっていて、それはまあそれで良いとしても、オブジェクトやコレクションからメソッドやプロパティがリンクされていないことだ。そのため、どのオブジェクトで何が使えるかさっぱりわからない。

一部についてはインテリセンスが効くから良いとしても、Selectionなんかはインテリセンスが効かないので全然だ。

で、うまく動くときは、上でWorkSheet(5)としているシートがフォアグラウンドとして表示されている時だということがわかり、しかし、なぜそうでなければうまく動かないかわからなかった。

で、これを書いていてわかったが、Selectionは移出されたオブジェクトではなく、デフォルトオブジェクトであるApplicationのプロパティで、アクティブなウィンドウの選択を返すから、うまく動いたり（WorkSheet(5)がフォアグラウンドシート)、動かなかったり（WorkSheet(5)以外のシートがフォアグラウンドシート）するからなのか。考えてみれば、それはそうだな、と納得できるが、とても不思議だった。

というか、もう少し手を入れれば、ほとんど人手の介在は不要にできそうだ。

_ OOO

あらためて上のリストを見ると気に食わない。

こうだな。

'思い出して書いているので嘘もあるはず。
Set src = WorkSheets(4)   ' Setを忘れやすい
Set dst = WorkSheets(5)
x = 100
y = 200
For r = 10 To 300
  If src.Range("F" & r).Value = "" Then
    Exit For  ' カラムFが空なら終了
  End If
  Set rc = CreateRect(dst, x, y, 240, 40, src.Range("F" & r).Value, 12) ' see #c01
  If src.Range("G" & r).Value <> "" Then
    Set attr = CreateRect(dst, x, y - 24, 240, 12, src.Range("G" & r).Value, 11)
    attr.Select True   ' 以前の選択をちゃらにする
    rc.Select False    ' 現在の選択に追加
    Selection.ShapeRange.Group ' 2つ四角を作った場合はグループ化
  End If
  x = x + 260
  y = y + 80
Next
...
Private Function CreateRect(ByVal dst As WorkSheet, ByVal x As Single, ByVal y As Single, ByVal w As Integer, ByVal h As Integer, ByRef txt As String, ByVal sz As Integer)
    Set s = dst.Shapes.AddShape(msoShapeRectangle, x, y, w, h)
    With s.TextFrame
      .Characters.Text = txt
      .Characters.Font.Size = sz
    End With
    Set CreateRect = s
End Function

で、ここまでは良いとして、次の修正をするかどうかが思案どころだ。

おれは、平気だし、むしろ、次のようにしたほうが良いと思うが、純粋主義者であれば、CreateRectがそれ以外のロールを果たすことに嫌な匂いを嗅ぐと想像できるからだ。

Set src = WorkSheets(4)   ' Setを忘れやすい
Set dst = WorkSheets(5)
x = 100
y = 200
For r = 10 To 300
  Set rc = CreateRect(dst, x, y, 240, 40, src.Range("F" & r).Value, 12)
  If rc Is Nothing Then
    Exit For
  End If
  Set attr = CreateRect(dst, x, y - 24, 240, 12, src.Range("G" & r).Value, 11)
  If Not attr Is Nothing Then
    attr.Select True   ' 以前の選択をちゃらにする
    rc.Select False    ' 現在の選択に追加
    Selection.ShapeRange.Group ' 2つ四角を作った場合はグループ化
  End If
  x = x + 260
  y = y + 80
Next
...
Private Function CreateRect(ByVal dst As WorkSheet, ByVal x As Single, ByVal y As Single, ByVal w As Integer, ByVal h As Integer, ByRef txt As String, ByVal sz As Integer)
    If txt = "" Then ' fixed on 4/22 (see #c04)
      Set CreateRect = Nothing ' see #c01
      Exit Function
    End If
    Dim s As WorkSheet ' fixed at 4/21
    Set s = dst.Shapes.AddShape(msoShapeRectangle, x, y, w, h)
    With s.TextFrame.Characters ' fixed see #c04
      .Text = txt
      .Font.Size = sz
    End With
    Set CreateRect = s
End Function