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 ' *----*----* *----*----* *----*----* *----*----*