Sub MyCellSide()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem アクティブセル＆右隣セル値Word書き出し処理
  Rem （セル選択位置の横に、ポップアップメニューを常に表示して対処）
  Rem 作譜：Hitrock Camellia Shinopy
  Rem 言語：Excel VBA
  Rem 機能...
  Rem   アクティブセルと右隣セルをWordに書き出す。
  Rem 注記...
  Rem   1. このマクロを実行し、ポップアップメニューを表示しておく。
  Rem   2. Wordに書き出ししたいセルを、マウスでクリックして選択する。
  Rem      （右隣セルの右側にポップアップメニューが移動する。）
  Rem   3. ポップアップメニューの[OK]ボタンを押して、
  Rem      アクティブセルと右隣セルの値をWordに書き出す｡
  Rem 履歴...
  Rem   第01版：2007/11/02：作成。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  Dim myCcAddr As String
  Dim x As Long
  Dim y As Long
  '
  myTitle = "MyCellSide"
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  On Error Resume Next
  CommandBars(myTitle).Delete
  On Error GoTo 0
  '
  Call MyCellSideCmmdBar(myTitle)
  '
  Beep
  Do
    On Error Resume Next
    myCcAddr = ActiveSheet.Columns(ActiveCell.Column).Offset(0, 1).Address(False, False)
    myCcAddr = Left(myCcAddr, InStr(myCcAddr, ":") - 1)
    x = ActiveSheet.Columns("A:" & myCcAddr).Width
    y = ActiveSheet.Rows("1:" & ActiveCell.Row).Height
    '
    x = ActiveWindow.PointsToScreenPixelsX(x * 1.333)
    y = ActiveWindow.PointsToScreenPixelsY(y * 1.333)
    y = y - (ActiveCell.Height * 1.333)
    '
    CommandBars(myTitle).ShowPopup x, y
    On Error GoTo 0
    '
    DoEvents
    If CommandBars(myTitle).Controls(1).FaceId = 1088 Then Exit Do
  Loop
  '
  On Error Resume Next
  CommandBars(myTitle).Delete
  On Error GoTo 0
End Sub ' MyCellSide *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCellSideCmmdBar(myTitle As String)
  Dim myCmmdBar As CommandBar
  Dim myCtrlBttn As CommandBarControl
  Dim myCtrlBttnOk As CommandBarControl
  Dim myCtrlBttnEnd As CommandBarControl
  Dim myMsg As String
  '
  Set myCmmdBar = CommandBars.Add(Name:=myTitle, Position:=msoBarPopup, Temporary:=True)
  Set myCtrlBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
  Set myCtrlBttnOk = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True)
  Set myCtrlBttnEnd = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True)
  '
  myMsg = myTitle & vbCrLf
  myMsg = myMsg & "アクティブセル"
  myMsg = myMsg & "＆右隣セル" & vbCrLf
  myMsg = myMsg & "Word書き出し処理：" & vbCrLf
  '
  With myCtrlBttn
    .DescriptionText = "アクティブセル＆右隣セルWord書き出し処理ポップアップメニュー"
    .Style = msoButtonIconAndWrapCaption
    .Caption = myMsg & "処理を実行しますか？"
    .TooltipText = "処理を実行しますか？"
    .FaceId = 1089
  End With
  '
  With myCtrlBttnOk
    .DescriptionText = "[OK]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "OK"
    .TooltipText = "処理を実行します。"
    .FaceId = 567
    .OnAction = myTitle & "BttnOk"
  End With
  '
  With myCtrlBttnEnd
    .DescriptionText = "[終了]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "終了" & String(12, "　")
    .TooltipText = "処理を終了します。"
    .FaceId = 1088
    .OnAction = myTitle & "BttnEnd"
  End With
End Sub ' MyCellSideCmmdBar *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCellSideBttnOk(Optional myDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コマンドボタン[OK]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
  '
  myText = ActiveCell.Value & " : " & ActiveCell.Offset(0, 1).Value
  myWord.Selection.TypeText myText & vbCrLf
  '
  myWord.WindowState = 2 ' wdWindowStateMinimize
  ' CommandBars("MyCellSide").Controls(1).FaceId = 567
End Sub ' MyCellSideBttnOk *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCellSideBttnEnd(Optional myDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コマンドボタン[終了]OnAction処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  CommandBars("MyCellSide").Controls(1).FaceId = 1088
End Sub ' MyCellSideBttnEnd *----*----*    *----*----*    *----*----*    *----*----*