Word VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム

360 / 886

←次へ　｜　前へ→


	【541】Re:エクセルに入力した文字列をワードに入力

H. C. Shinopy - 07/11/3(土) 21:52 -


	引用なし

	パスワード

『エクセルのＣ列ｎ行目とＤ列ｎ行目に入力した２つの文字列をＡ列ｎ行目をクリックする…』ということですが、Ａ列全行にボタンを作るわけにはいかないでしょう。

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

2,759 hits

▼

【539】エクセルに入力した文字列をワードに入力 ｋ．ぬま 07/10/30(火) 22:57