Sub MyShapeCmmdBttn()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem アクティブセル&右隣セル値Word書き出し処理
  Rem (左端セルにコマンドボタンを設定して対処)
  Rem 作譜:Hitrock Camellia Shinopy
  Rem 言語:Excel VBA
  Rem 機能...
  Rem   左端セルにコマンドボタンを設定しておき、右側のセルと右隣セルをWordに書き出す。
  Rem 注記...
  Rem   1. このマクロを実行し、左端セル(A:B)にコマンドボタンを設定しておく。
  Rem   2. コマンドボタンを押すと、右側のセル(C:D)の値がWordに書き出される。
  Rem 履歴...
  Rem   第01版:2007/11/02:作成。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  Dim i As Long
  '
  Dim myCcAddr As String
  Dim myWidth As Long
  Dim myTop As Long
  Dim myLeft As Long
  Dim myHeight As Long
  '
  Dim myShape As Shape
  Dim myOnAction As String
  '
  myTitle = "MyShapeCmmdBttn"
  '
  For i = 2 To 10
    Cells(i, "A").Select
    '
    myCcAddr = ActiveSheet.Columns(ActiveCell.Column).Address(False, False)
    myCcAddr = Left(myCcAddr, InStr(myCcAddr, ":") - 1)
    myWidth = ActiveSheet.Columns("A:B").Width
    myTop = ActiveSheet.Rows("1:" & ActiveCell.Row).Height
    myTop = myTop - ActiveCell.Height
    '
    myLeft = ActiveSheet.Range(ActiveCell.Address(False, False)).Left
    myHeight = ActiveSheet.Range(ActiveCell.Address(False, False)).Height
    '
    Set myShape = ActiveSheet.Shapes.AddFormControl(xlButtonControl, myLeft, myTop, myWidth, myHeight)
    With myShape
      .Name = ActiveCell.Address(False, False)
      .TextFrame.Characters.Font.Size = 10
      .TextFrame.Characters.Text = Cells(ActiveCell.Row, "C").Value
      .AlternativeText = .Name
      myOnAction = myTitle & "MyRun" & " "
      myOnAction = myOnAction & Chr(&H22) & .Name & ChrW(&H22)
      .OnAction = "'" & myOnAction & "'"
    End With
  Next ' i
End Sub ' MyShapeCmmdBttn ' *----*----*    *----*----*    *----*----*    *----*----*

Sub MyShapeCmmdBttnMyRun(myAddress As String)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コマンドボタンOnAction処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myWord As Variant ' Word.Application
  Dim myWordDoc As Variant ' Word.Document
  Dim myText As Variant
  '
  On Error Resume Next
  Set myWord = GetObject(, "Word.Application")
  If Err.Number <> 0 Then
    Set myWord = CreateObject("Word.Application")
    Set myWordDoc = myWord.Documents.Add
    myWord.Visible = True
  End If
  On Error GoTo 0
  '
  Range(myAddress).Offset(0, 2).Select
  myText = ActiveCell.Value & " : " & ActiveCell.Offset(0, 1).Value
  myWord.Selection.TypeText myText & vbCrLf
  '
  myWord.WindowState = 2 ' wdWindowStateMinimize
End Sub ' MyShapeCmmdBttnMyRun ' *----*----*    *----*----*    *----*----*    *----*----*
inserted by FC2 system