| |
『エクセルのＣ列ｎ行目とＤ列ｎ行目に入力した２つの文字列をＡ列ｎ行目をクリックする…』ということですが、Ａ列全行にボタンを作るわけにはいかないでしょう。
C列をクリックして、その横にポップアップメニューを表示させ、
ポップアップメニューのボタンを押して、Wordに書き込むほうがいいと思います。
Excelのマクロで、処理可能です。
以下は、右隣セルの右側にポップアップメニューを表示させ、アクティブセルと右隣セルをWordに書き出すとして考えました。
このマクロを実行すると、最初は思わぬ所にポップアップメニューが表示されますが、
それに構わず、C列をマウスでクリックして（すると、E列にポップアップメニューが移動して表示されます。）、[OK]ボタンを押すと、C列とD列をWordに書き出しします。
貴殿のお考えとは大きく違いますが、細かいところは御自分で変えて頂ければと思います。
Sub MyCellSide()
Rem *----*----* *----*----* *----*----* *----*----*
Rem アクティブセル＆右隣セルWord書き出し処理
Rem 言語：Excel VBA
Rem 機能...
Rem アクティブセルと右隣セルをWordに書き出す。
Rem 注記...
Rem 右隣セルの横にポップアップメニューを表示しておき、
Rem セルをマウスでクリックして選択し、[OK]ボタンを押して、
Rem アクティブセルと右隣セルをWordに書き出す｡
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 & vbCrLf
myMsg = myMsg & "アクティブセル" & vbCrLf
myMsg = myMsg & "＆右隣セル" & vbCrLf
myMsg = myMsg & "Word書き出し処理" & vbCrLf & 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 & "BttnMyOk"
End With
'
With myCtrlBttnEnd
.DescriptionText = "[終了]ボタン"
.Style = msoButtonIconAndCaption
.Caption = "終了" & String(12, " ")
.TooltipText = "処理を終了します。"
.FaceId = 1088
.OnAction = myTitle & "BttnMyEnd"
End With
End Sub ' MyCellSideCmmdBar *----*----* *----*----* *----*----* *----*----*
Sub MyCellSideBttnMyOk(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 ' MyCellSideBttnMyOk *----*----* *----*----* *----*----* *----*----*
Sub MyCellSideBttnMyEnd(Optional myDummy As Boolean)
Rem *----*----* *----*----* *----*----* *----*----*
Rem コマンドボタン[終了]OnAction処理
Rem *----*----* *----*----* *----*----* *----*----*
'
CommandBars("MyCellSide").Controls(1).FaceId = 1088
End Sub ' MyCellSideBttnMyEnd *----*----* *----*----* *----*----* *----*----*
|
|
とき
- 07/12/13(木) 13:56 -
- 07/11/21(水) 11:26 -
k.ぬま
H. C. Shinopy
- 07/11/11(日) 23:41 -
