転記先のExcelを開かない方法

質問

システムからWordの送り状をダウンロードし、その宛先をExcelの郵便管理簿に
転記しているのですが、いちいちExcelを開くのが手間なので、
省くことはできないでしょうか？

Wordのマクロ
Sub 社名をコピー()
If MsgBox("以下をコピーしてエクセルに転記しますか？" & vbLf & vbLf _
& LineSentence(5), vbYesNo) = vbYes Then
エクセルに転記
End If
End Sub

Function LineSentence(posL As Long) As String
With Selection
.GoTo wdGoToLine, wdGoToAbsolute, posL
.SetRange .Start, .Sentences(1).End
.Copy
LineSentence = .Text
End With
End Function

Sub エクセルに転記()
Dim ourR As String
On Error Resume Next
ourR = Selection.Text
With GetObject(, "Excel.Application")
.Visible = True
.Run "見積コピー", ourR
End With
End Sub

Excelのマクロ
Sub 見積コピー(ourR As String)
Sheets(Month(Now()) & "月").Select
Range("C1048576").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End Sub

回答No.5

real beatin（@realbeatin） · ベストアンサー

＃２-４です。
＃３補足欄拝見しました。

> ... パソコンに不慣れな人に ...
私のＶＢＡもスキルが読めないエンドユーザーを相手に書くことが多いので、
あなたの配慮はよく解ります。

> 500行目まで罫線が引いてあり ... 501行目に転記されました。
罫線のことは考えていませんでしたが、ADODBの仕様でそうなります。

> #正しい行位置#（20行目）に転記する ...
対策しました。

> できる所まで作ってみますので、後日、またアドバイスをお願いします。
今回提示したものはメンテが難しいでしょうから、
その時が来るまでのツナギということで考えておいてください。
ご縁があればまたその時に(^^)

> ... 方法２がうまく作動するように ...
正しい行位置に転記する、
転記先ブックが開いている場合の対策強化、他、
修正後の全体を掲げます。
＃３のは破棄してください（もう一度初期設定お願いします）。
もしも不足があるといけないので、厳しめに検証してみて,
必要ならまた補足下さい。

' ' ///　方法２）ADODB.Recordset版　改★　///　8990156w

Sub 社名をコピー31()
Dim rtn, s As String
'' ' 現在開いているドキュメント の ５行め のテキスト を 取得（option 1/2）
'　　s = ActiveDocument.Paragraphs(5).Range.Text
' ' 現在選択中のページ の ５行め のテキスト を 取得（option 2/2）どちらがいいか選んでください
　　s = ActiveDocument.Bookmarks("\Page").Range.Paragraphs(5).Range.Text　'★
' ' テキスト から 改行 を トル
　　s = Replace$(s, vbCr, "")
' ' メッセージを表示して 処理の可否 を 問う（文面は編集可）
　　If MsgBox("以下のデータをエクセルに転記3しますか？" & vbLf & vbLf & s, vbYesNo) = vbYes Then
' ' 'エクセルに転記31' を 実行
　　　　rtn = エクセルに転記31(s)
　　　　If rtn = True Then　'★↓
' ' 'エクセルに転記31' が正常終了ならば メッセージ（文面は編集可） を 表示
　　　　　　MsgBox vbTab & s & vbLf & "を、エクセルに転記しました", vbInformation
　　　　Else
' ' 'エクセルに転記31' が 不正終了ならば メッセージ（文面は編集可） を 表示
　　　　　　MsgBox "'エクセルに転記31'処理できませんでした。" & _
　　　　　　　　vbLf & "◆初期設定◆の内容を確認してください。" & _
　　　　　　　　vbLf & vbLf & "err#:" & rtn & vbLf & Error(rtn) _
　　　　　　　　, vbExclamation, "処理に失敗！／'エクセルに転記31'"
　　　　End If　'★↑
　　End If
End Sub

Private Function エクセルに転記31(s As String) As Long
Const xlReadOnly = 3, xlReadWrite = 2　'　固定　'★
Const myProv = "Microsoft.ACE.OLEDB.12.0"　'　固定
Const adOpenStatic = 3, adLockOptimistic = 3, adCmdText = 1　'　固定

Dim oXlApp As Object　'　Excel.Application　'★
Dim oXlWkB As Object　'　Excel.Workbook　'★
Dim oConn As Object　'　New ADODB.Connection
Dim rs As Object　' New ADODB.Recordset
Dim myFullPath As String　'　転記先ブックへのフルパス　'★
Dim myShortName As String　'　転記先ブックの名前　'★
Dim mySheet As String　'　シート名
Dim myRef As String　'　セル範囲
Dim nLast As Long　'　行位置

' ' ◆初期設定◆ 指定は正確に！！間違っていればエラーになります
　　myFullPath = "D:\フォルダ名\郵便管理簿.xlsx"　'　要指定◆転記先ブックへのフルパス（フルネーム）
　　mySheet = Month(Date) & "月"　'　要指定◆シート名　今月　 & "月"　？
　　myRef = "A1:J1048575"　'　要指定◆セル範囲／大きめの範囲を指定してＯＫ

' ' ●--- 転記先ブック 開いていたら 読み取り専用に ---●
On Error Resume Next　'★↓
　　Set oXlApp = GetObject(, "Excel.Application")
On Error GoTo 0
　　If Not oXlApp Is Nothing Then
　　　　myShortName = Mid$(myFullPath, InStrRev(myFullPath, "\") + 1) '　転記先ブックのショートネーム を 取得
On Error Resume Next
　　　　Set oXlWkB = oXlApp.Workbooks(myShortName)
On Error GoTo 0
　　　　If Not oXlWkB Is Nothing Then
　　　　　　oXlWkB.Saved = True
　　　　　　oXlWkB.ChangeFileAccess xlReadOnly, , False
　　　　End If
　　End If　'★↑

' ' ●--- Connection ---●
On Error GoTo errOut0_
　　Set oConn = CreateObject("ADODB.Connection")
　　' ' データソース（Excelブック）へのコネクション 開く
　　oConn.Open "Provider=" & myProv & _
　　　　　　　　";Data Source=" & myFullPath & _
　　　　　　　　";Extended Properties=""Excel 12.0;HDR=No;ReadOnly=True;"""

' ' ●--- Recordset ---●
On Error GoTo errOut1_
　　Set rs = CreateObject("ADODB.RecordSet")
　　With rs
　　　　' ' レコードセット 開く
　　　　.Open "SELECT * FROM [" & mySheet & "$" & myRef & "]", _
　　　　　　　　　　oConn, adOpenStatic, adLockOptimistic, adCmdText

　　　　' ' 第３フィールド Nullでないレコードを検索
　　　　.MoveLast　'★↓
　　　　nLast = .RecordCount
　　　　Do While nLast
　　　　　　If Not IsNull(.Fields(2).Value) Then Exit Do
　　　　　　.MovePrevious
　　　　　　nLast = nLast - 1
　　　　Loop
　　　　If nLast = .RecordCount Then
　　　　　　.AddNew　'　レコードを追加
　　　　Else
　　　　　　.MoveNext　'　転記先のレコードにカーソル移動
　　　　End If　'★↑
　　　　' ' レコード の第３フィールド（指定値は(2)）に データ を 転記
　　　　.Fields(2).Value = s
On Error Resume Next
　　　　' ' レコードセット（Excelブック）を 更新
　　　　.Update
　　　　' ' 追加したデータ を 確認 処理が正常に終了したこと を 戻り値に
　　　　If .Fields(2).Value = s Then エクセルに転記31 = True

' ' ●--- オブジェクト の 後片付け ---●
　　　　.Close
　　End With

errOut1_:
　　oConn.Close
errOut0_:
' ' 読み取り専用ブック を 元に戻す　★↓
　　If Not oXlWkB Is Nothing Then
　　　　oXlWkB.Saved = True
　　　　oXlWkB.ChangeFileAccess xlReadWrite, , False
　　　　Set oXlWkB = Nothing:　　Set oXlApp = Nothing
　　End If　'★↑
　　Set rs = Nothing: Set oConn = Nothing
　　If Err Then エクセルに転記31 = Err
End Function

' ' ///

お礼

realbeatinさん、ありがとうございました。

ばっちり、転記されました。

エクセルで実行するマクロは、別で質問したほうがよかったですか？
お返事がないようでしたら、新しく質問を立ち上げます。

今回はありがとうございました。

回答No.7

real beatin（@realbeatin）

遅くなりましたが＃４補足欄への返信です。

> アドバイスをお願いします。
ご提示のスクリプトはレベル高い内容だと私は思います。
ファイル名を読むようにする設計は目から鱗でした。
簡単で解り易い記述で出来ちゃうし、軽いし、、、。
そのままご自身で仕上げていけそうな気もしますが、
私からは、アドバイスというより、アイディアとかパーツの紹介、的な？

> 担当者名も取得したいのですが、難しいので、宛先だけにしました。
まずは愚直なやり方ですが、
ExcelからWordドキュメントを開いて読むやり方なら、
一度形が解れば、そうは難しくないでしょうから、
ちょっと書いてみました。
例えば仮に、[担当者名]について、
　Word側の　６行め　を読んで
　Excel側の　Ｄ列　に書き込む
というような場合です。
この場合は[郵便宛先]もファイル名でなくてもテキストデータからも読めます。
以下、「'Cセルにファイル名を書き出し」ブロックに相当する記述です。
' ' ///
Dim oWdApp As Object　'　Word.Application
Dim oWdDoc As Object　'　Word.Document
Dim sPath As String
' Wordアプリケーション
　　On Error Resume Next
　　Set oWdApp = GetObject(, "Word.Application")　'　Word.Application探す
　　On Error GoTo 0　'　無ければ作る　↓
　　If oWdApp Is Nothing Then Set oWdApp = CreateObject("Word.Application")

'Cセルにファイル名を書き出し
　　i = Range("C" & Rows.Count).End(xlUp).Row
　　For Each fl In fso.GetFolder(fd_path).Files
　　　　sPath = fl.Path
　　　　If LCase$(fso.GetExtensionName(sPath)) Like "doc?" Then　' 拡張子で篩に掛ける
　　　　　　i = i + 1
' Cells(i, "C").Value = fso.GetBaseName(sPath)　'　[郵便宛先]（拡張子抜き）
　　　　　　Set oWdDoc = oWdApp.Documents.Open(sPath, , True)　'　Word.Document開く
　　　　　　With oWdDoc.Paragraphs
　　　　　　　　Cells(i, "C").Value = Replace(.Item(5).Range.Text, vbCr, "")　'　[郵便宛先]
　　　　　　　　Cells(i, "D").Value = Replace(.Item(6).Range.Text, vbCr, "")　'　[担当者名]　"D" ? 6 ?
　　　　　　End With
　　　　　　oWdDoc.Close
　　　　End If
　　Next fl
　　Set oWdDoc = Nothing:　　oWdApp.Quit:　　Set oWdApp = Nothing
' ' CreateObjectした場合.Quitは必須。GetObjectの場合は.Quitしない方が本当は正しい。（略）
' ' ///
ドキュメントをすべて開くのでそれなりに時間は掛かりますが、
都度更新することを考えれば、全体の作業としては時短出来ているでしょう。
もっと処理を速くしたいとお考えでしたら、私には教えられることはありませんが、
「xdoc2txt」とかいうのが使えるかもしれません？（OKWave内の検索でも情報あります）

いっそのこと、担当者名もファイル名に加えてみるのはどうでしょう。
ファイル名に自由が許されて、フルパスで文字制限に収まるなら、ですが、、、。
http://salaryman-life.blogspot.jp/2013/06/windows.html
"郵便宛先■担当者名.docx" のように
適当な区切り文字決めて名前を付けておいて、
　　ary = Split(fso.GetBaseName(sPath), "■")　'　（拡張子抜き）
　　Cells(i, "C").Value = ary(0)　'　[郵便宛先]
　　Cells(i, "D").Value = ary(1)　'　[担当者名]
みたいやり方もあるかな、と。
さらに例えば、
ファイル名の重複や異種のドキュメントの混入なども想定するとか、
拡張子を切り離しやすくする意味で、
"■郵便宛先■担当者名■発送日付yymmdd■.docx"
のようにしておいて、
' ' ///
'Cセルにファイル名を書き出し
Dim Ary() As String
Dim sName As String
　　For Each fl In fso.GetFolder(fd_path).Files
　　　　sName = fl.Name
　　　　If LCase$(sName) Like "■*■.doc?" Then　'　接頭句/接尾句/拡張子で篩に掛ける
　　　　　　i = i + 1
　　　　　　ary = Split(sName, "■")　'　区切り文字で配列に
　　　　　　Cells(i, "C").Value = ary(1)　'　[郵便宛先]
　　　　　　Cells(i, "D").Value = ary(2)　'　[担当者名]
　　　　End If
　　Next fl
' ' ///
これだとWordを開く必要もなく、処理も遅くないですし。
ファイル名を変更されるようなことが無いなら、こんなやり方もアリかと思います。

少し意外に感じたのは、FileDialogFolderPickerのことですけれど、
ある意味堅いやり方なんだと思いますから、そのままでもいいのですが、
例えば、月別のフォルダを設けて
' ' /// Word側 ///
　　folder = "\\osaka\Users\■分室\★☆受渡し用☆★\郵便\" & Month(Date) & "月"
' ' ///
' ' /// Excel側 ///
Dim rtn
　　rtn = InputBox("月を指定して'郵便宛先読込'を実行します", "郵便宛先読込", Month(Date))
　　'キャンセル時にマクロを終了
　　If rtn = "" Then Exit Sub　'　1-12 の数字でない場合を判別するのがベター
　　'フォルダのフルパスを格納
　　fd_path = "\\osaka\Users\■分室\★☆受渡し用☆★\郵便\" & rtn & "月"
' ' ///
みたいなやり方もあるのかなぁ、と。

でもまぁ実情も解らずに想像で書いていることですから、
ニーズから逸れたことばかり書いちゃったかも知れないですね。
以上、差し当たり、思い付き程度の内容ですが、
ご提示の基本設計は結構しっかりしていると思うので、
あとは、また運用の実態をみながら、
少しずつ手を加えていけば、きっとうまく行くんじゃないかと思っています。
＃長くなってすみません(~^;)

お礼

realbeatinさん、お忙しい中、ありがとうございます。
朝、５時前に投稿いただいてますが、徹夜されたのでしょうか？
本当に、ありがとうございます。

お褒めいただき、ありがとうございます。
いろいろなHPから拝借したマクロを利用させていただいただけなので恥ずかしいです。

いろいろアドバイスいただきましたが、担当者名もファイル名にし、エクセルに転記するとき
区分けするようにしたいと思います。
ただ、システムからダウンロードしたファイルなので、名前の後になにか入っているようで
それがエラーを起こしているみたいです。

新しく質問しますので、できれば引き続きお願いいたします。

回答No.6

real beatin（@realbeatin）

> エクセルで実行するマクロは、別で質問したほうがよかったですか？
あいえ、先の投稿を文字数制限に収めるのに時間かかってしまい、
＃４補足に気が付かなかっただけなのです。その後、
ＰＣに触れる時間が無いものですから、、、ただそれだけですよ(^^)

> お返事がないようでしたら、新しく質問を立ち上げます。
その方がベターとは思いますが、
時間を置いて後程１レスするつもりではいました。
どちらでもいいですよ。
では、また。

回答No.4

real beatin（@realbeatin）

＃２-３です。連投失礼。

> システムからWordの送り状をダウンロードし、その宛先をExcelの郵便管理簿に
> 転記しているのですが、いちいちExcelを開くのが手間なので、
> 省くことはできないでしょうか？

ご提示のマクロの記述を見て、私が話を合わせ過ぎていたかも知れないな、
と思っています。
以下、参考になれば。

例えば、
発想を切り替えて、全体の運用や設計を見直すことができるのなら、
　　郵便管理簿のあるExcelブックの方から、マクロを実行するようにして、
　　送り状の宛先が記されたWordドキュメント達を複数、一気に読みに行く
という風にしてみては如何でしょう？（状況が許すなら、、、ですが）

差し当たり、
閉じたままの郵便管理簿ブックを参照することは今まで無かった筈ですから、
「郵便管理簿に用がある時」＝「郵便管理簿ブックを開く時」なのでしょうから、
「郵便管理簿ブックを開いた時」にマクロを実行して、
送り状の宛先をまとめて吸い取るように
設計や運用を変えることができれば、合理的になるような気がしています。

Excelからみて、
処理の対象となるWordドキュメントの名前とか名前のフォーマットとかフォルダパスとか、
要するに読み込むデータがどこにあるか判るような状況が用意出来れば、
都度都度処理する必要はないのかも、と想像しています。

現実には、Wordを編集中に都度マクロを実行している訳ですから、
何かしら目視での確認や手作業が必要なのは解りますけれど、
作業の全体を見渡して、どこまで自動化できるか、、、
実は最終的な確認と添え書きだけ手作業で、そこに至るまでのすべてが自動化できる可能性がある、
というような目で見てみていくと、色々最適化できる点があるようにも想います。
でもまぁ「システムから」ということですから、
本来はシステム管理者に要求したり相談したり、という案件なのかも知れませんね。
もし私なら、そして自分の裁量で決められるなら、
処理をなるべく一纏めに済ませるように運用して、手数が少ない方法を選ぶ、
と、普段通りの自分なら、そういう切り口を
質問を読んで最初に考える筈なのに、、、などと思い直したので、
再レスしてみました。

参考とはいいながら、
決して簡単な話ではありませんが、もし可能性があるのなら、
余裕のある時にでも、少しだけ考えてみて下さい。
もし、補足があって条件が整ったなら、またお応えするつもりです。

以上、永、失礼しました。

補足

エクセルからワードの文章を取得するVBAです。
担当者名も取得したいのですが、難しいので、宛先だけにしました。
アドバイスをお願いします。

Sub 宛名変更保存Word()

Dim folder As String
Dim s As String

' ' 現在開いているドキュメント の ５行め のテキスト を 取得
s = ActiveDocument.Paragraphs(5).Range.Text
' ' テキスト から 改行 を トル
s = Replace$(s, vbCr, "")

folder = "\\osaka\Users\■分室\★☆受渡し用☆★\郵便"

With CreateObject("Scripting.FileSystemObject")
If .FolderExists(folder) Then
ActiveDocument.SaveAs Filename:=folder & "\" & s & ".docx"
Else
MsgBox "存在しません"
End If
End With
End Sub

エクセルの「郵便管理簿」に保存したマクロ
Sub 郵便宛先読込()

Dim dlg As FileDialog
Dim fd_path As String
Dim fso As Object 'Scripting.FileSystemObject
Dim fl As Object 'Scripting.File
Dim i As Long

Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
'キャンセル時にマクロを終了
If dlg.Show = False Then Exit Sub

'フォルダのフルパスを格納
fd_path = dlg.SelectedItems(1)

Set fso = CreateObject("Scripting.FileSystemObject")

If fso.GetFolder(fd_path).Files.Count < 1 Then
MsgBox fd_path & " にはファイルが存在しません。"
Set fso = Nothing
Exit Sub
End If

Sheets(Month(Now()) & "月").Select
Range("C1").Value = fd_path

'Cセルにファイル名を書き出し
i = Range("C" & Rows.Count).End(xlUp).Row + 1
For Each fl In fso.GetFolder(fd_path).Files
Cells(i, "C").Value = fl.Name
i = i + 1
Next fl

Set fso = Nothing

MsgBox Sheets(Month(Now()) & "月").Name & "にファイル名一覧を作成しました。"
End Sub

回答No.3

real beatin（@realbeatin）

' 前の投稿の続きです。

' ' ///　方法２）ADODB.Recordset版　///　8990156w

Sub 社名をコピー3()
Dim rtn
Dim s As String
' ' 現在開いているドキュメント の ５行め のテキスト を 取得
　　s = ActiveDocument.Paragraphs(5).Range.Text
' ' テキスト から 改行 を トル
　　s = Replace$(s, vbCr, "")
' ' メッセージを表示して 処理の可否 を 問う（文面は編集可）
　　If MsgBox("以下のデータをエクセルに転記3しますか？" & vbLf & vbLf & s, vbYesNo) = vbYes Then
' ' 'エクセルに転記3' を 実行
　　　　rtn = エクセルに転記3(s)
' ' 'エクセルに転記3' が 不正終了ならば メッセージ（文面は編集可） を 表示
　　　　If rtn <> True Then MsgBox "'エクセルに転記3'処理できませんでした。" & _
　　　　　　　　vbLf & "◆初期設定◆の内容を確認してください。" & _
　　　　　　　　vbLf & vbLf & "err#:" & rtn & vbLf & Error(rtn) _
　　　　　　　　, vbExclamation, "処理に失敗！／'エクセルに転記3'"
　　End If
'　　Beep
End Sub

Private Function エクセルに転記3(s As String) As Long
Const myProv = "Microsoft.ACE.OLEDB.12.0"　'　固定▼
'Const myProv = "Microsoft.Jet.OLEDB.4.0"　'　固定▲旧い環境の場合は、上の行と差し替え
Const adOpenStatic = 3, adLockOptimistic = 3, adCmdText = 1　'　固定

Dim oConn As Object　'　As New ADODB.Connection
Dim rs As Object　'　As New ADODB.Recordset
Dim myPath As String　'　転記先ブックへのフルパス
Dim mySheet As String　'　シート名
Dim myRef As String　'　 セル範囲

' ' ◆初期設定◆要指定◆ 予め運用に合わせて設定しておいてから 実行
' ' 指定は正確に！！間違っていればエラーになります
　　myPath = "D:\フォルダ名\郵便管理簿.xlsx"　'　要指定◆転記先ブックへのフルパス（フルネーム）
　　mySheet = Month(Date) & "月"　'　要指定◆シート名　今月　 & "月"　？
　　myRef = "A1:J1048575"　'　要指定◆セル範囲／大きめの範囲を指定しても処理に影響しない

' ' ●--- Connection ---●
On Error GoTo errOut0_
　　Set oConn = CreateObject("ADODB.Connection")
　　' ' データソース（Excelブック）へのコネクション 開く
　　oConn.Open "Provider=" & myProv & _
　　　　　　　　";Data Source=" & myPath & _
　　　　　　　　";Extended Properties=""Excel 12.0;HDR=No;ReadOnly=True"""

' ' ●--- Recordset ---●
On Error GoTo errOut1_
　　Set rs = CreateObject("ADODB.RecordSet")
　　With rs
　　　　' ' レコードセット 開く
　　　　.Open "SELECT * FROM [" & mySheet & "$" & myRef & "]", _
　　　　　　　　　　oConn, adOpenStatic, adLockOptimistic, adCmdText
　　　　' ' レコード を 追加
　　　　.AddNew
　　　　' ' 追加したレコード の３番目（指定値は(2)）のフィールド に データ を 転記
　　　　.Fields(2).Value = s
　　　　' ' レコードセット（閉じたままのExcelブック）を 更新
On Error Resume Next
　　　　.Update
　　　　' ' 追加したデータ を 確認
　　　　' ' 処理が正常に終了したこと を 戻り値に返す
　　　　If .Fields(2).Value = s Then エクセルに転記3 = True

' ' ●--- ADODB オブジェクト の 後片付け（「閉じる」「解放する」 ---●
　　　　.Close
　　End With

errOut1_:
　　oConn.Close
errOut0_:
　　Set rs = Nothing: Set oConn = Nothing
　　If Err Then エクセルに転記3 = Err
End Function

' ' ///

補足

realbeatinさん、前回はありがとうございました。

あれから、パソコンに不慣れな人に使ってもらっていたのですが
毎日ではない、ということもあり、エクセルを開くタイミングや
マクロを動かすタイミングを忘れたということがたびたびあり
今回、再度質問させていただきました。

方法２が速そうで、Office2010なので、こちらにしました。
しかし、転記するセルを取得できません。
500行目まで罫線が引いてあり、A列とI列には数字と関数が入っています。
マクロを実行すると、501行目に転記されました。
転記するA20行目からI501行目まで、deleteで削除し、上書き保存しました。
再度、マクロを実行すると、502行目に転記され、コを90度回転させた形に罫線が引かれました。
20行目に転記するには、どこを変更すればいいのでしょうか？

あと、エクセルからマクロを実行して、値を取得するというご提案、素晴らしいです！
サーバーにフォルダーを作成し、そこへマクロボタンで保存してもらい
最後にマクロで宛先と担当者を取得する、とすればいいのですよね？
できる所まで作ってみますので、後日、またアドバイスをお願いします。

まずは、方法２がうまく作動するようにアドバイスをお願いします。

回答No.2

real beatin（@realbeatin）

こんにちは。

以前のご質問にお答えした者ですが、
『Wordの送付先名をエクセルに転記したい 』
http://okwave.jp/qa/q8945684.html
からの発展ということですね。

> システムからWordの送り状をダウンロードし、その宛先をExcelの郵便管理簿に
> 転記しているのですが、いちいちExcelを開くのが手間なので、
> 省くことはできないでしょうか？

開いている場合でも開いていない場合でも、
何度も繰り返し実行しても、
正しく処理される、
ということを慎重に考えないとトラブルの元ですね。
もし、ご自分で工夫される場合は注意してください。
＃ＶＢＡでオブジェクトを扱う場合の基本ですが、
　「開いたものは必ず閉じる」ように行儀よい記述を心掛けるようにしましょう。

方法はありますが、どれを採っても簡単ではないです。

方法１）Excelの画面を表示せずに処理する。
　記述が長くなり、処理も複雑で、（開いたり閉じたりが）ちょっと重いです。
　でも、概念的にはシンプルなので理解され易いと思います。

方法２）ADODB.Recordset オブジェクトを介して転記・更新する。
　比較的シンプルに書けますし、処理速いです。
　但し、転記先のExcelブックが開いた状態で、
　　繰り返しマクロ処理する合間に並行して手作業で編集したりすると
　　正しく一番下の行が取れないこともあります。
　　また、Office2007以前のバージョンでは、開いた状態のブックに限って
　　僅かながらメモリーリークが起る場合があります。

条件を確認してから、２つの方法の内、ひとつを、
現在お使いの記述すべてに代えて、試して、お使いください。
◆要指定◆の部分の各パラメータは、そちらでの運用に合わせて、
書換え（確認し）てから、実行するようにしてください。

＃レス、長くなるので、方法２）は次の投稿で。

' ' ///　方法１）　xlApp版　///　8990156w

Sub 社名をコピー2()
Dim rtn
Dim s As String
' ' 現在開いているドキュメント の ５行め のテキスト を 取得
　　s = ActiveDocument.Paragraphs(5).Range.Text　'　要指定◆ ５行め　？
' ' テキスト から 改行 を トル
　　s = Replace$(s, vbCr, "")
' ' メッセージを表示して 処理の可否 を 問う（文面は編集可）
　　If MsgBox("以下のデータをエクセルに転記しますか？" & vbLf & vbLf & s, vbYesNo) = vbYes Then
' ' 'エクセルに転記2' を 実行
　　　　rtn = エクセルに転記2(s)
' ' 'エクセルに転記2' が 不正終了ならば メッセージ（文面は編集可） を 表示
　　　　If rtn <> 0 Then MsgBox "'エクセルに転記2'処理できませんでした。" & _
　　　　　　　　vbLf & "◆初期設定◆の内容を確認してください。" & _
　　　　　　　　vbLf & vbLf & "err#:" & rtn & vbLf & Error(rtn) _
　　　　　　　　, vbExclamation, "処理に失敗！／'エクセルに転記2'"
　　End If
'　　Beep
End Sub

Private Function エクセルに転記2(s As String) As Long
Const xlUp = -4162
Const myNewXL = 1
Const myNewWbk = 2
Dim oXlApp As Object　'　As Excel.Application　'
Dim oXlWkB As Object　'　As Excel.Workbook　'
Dim myFullPath As String　'　転記先ブックへのフルパス
Dim myShortName As String　'　転記先ブックの名前
Dim ary() As String　'　ショートネーム取得用の配列変数
Dim mySheet As String　'　シート名
Dim myRef As String　'　 セル範囲
Dim flg As Integer

' ' ◆初期設定◆要指定◆ 予め運用に合わせて設定しておいてから 実行
' ' 指定は正確に！！間違っていればエラーになります
　　myFullPath = "D:\フォルダ名\郵便管理簿.xlsx"　'　要指定◆転記先ブックへのフルパス（フルネーム）
　　mySheet = Month(Date) & "月"　'　要指定◆シート名　今月　 & "月"　？
　　myRef = "C1048576"　'　要指定◆転記先検索の基準セルへの参照（列番地 = Ｃ列　？）

' ' ●--- 事前処理 ---●'　転記先ブックの名前（ショートネーム） を 取得
　　ary() = Split(myFullPath, "\")
　　myShortName = ary(UBound(ary()))

' ' ●--- 開いているExcelアプリケーション を 取得 ---●
' ' 　もし Excel が 開いていない場合は、下記 errXL_ で 新しいExcel を 開く
On Error GoTo errXL_
　　Set oXlApp = GetObject(, "Excel.Application")

' ' ●--- 開いている転記先ブック を 取得 ---●
' ' 　もし 転記先ブック が 開いていない場合は、下記 erWKB_ で 転記先ブック を 開く
On Error GoTo errWKB_
　　Set oXlWkB = oXlApp.Workbooks(myShortName)
On Error Resume Next
' ' ●--- 転記先セル に 値 を 設定 ---●
　　oXlWkB.Sheets(mySheet).Range(myRef).End(xlUp).Offset(1) _
　　　　.Value = s

' ' ●--- 転記先ブック を 上書き保存。元々開いていなかった場合は 閉じる ---●
　　If flg And myNewWbk Then
　　　　oXlWkB.Close True
　　Else
　　　　oXlWkB.Save
　　End If
　　Set oXlWkB = Nothing

errExit_:
' ' ●--- Excelアプリケーション 元々開いていなかった場合は 閉じる ---●
　　Set oXlWkB = Nothing
　　If flg And myNewXL Then
　　　　oXlApp.Quit
　　End If
　　Set oXlApp = Nothing

　　エクセルに転記2 = Err
　　Exit Function

errXL_:
' ' ●--- 新しいExcelアプリケーション を 開いて 取得 ---●
　　Set oXlApp = CreateObject("Excel.Application")
　　flg = flg Or myNewXL
　　Resume Next
errWKB_:
' ' ●--- 転記先ブック を 開いて 取得 ---●
　　If Dir(myFullPath) = "" Then
　　　　エクセルに転記2 = 101
　　　　GoTo errExit_
　　ElseIf エクセルに転記2 = 13 Then
　　　　GoTo errExit_
　　End If
　　エクセルに転記2 = 13

' ' 転記先ブック を 開いて 取得（パスワードがあるなら◆要指定◆）
　　Set oXlWkB = oXlApp.Workbooks.Open(myFullPath)　'　★option(1/4)
　　' ' ★読み取りパスワードを設定している場合　'　★option(2/4)
'　　Set oXlWkB = oXlApp.Workbooks.Open(myFullPath, , , , "読み取りパス")
　　' ' ★書き込みパスワードのみを設定している場合　'　★option(3/4)
'　　Set oXlWkB = oXlApp.Workbooks.Open(myFullPath, , , , , "書き込みパス")
　　' ' ★読み取り・書き込みパスワード両方を設定している場合　'　★option(4/4)
'　　Set oXlWkB = oXlApp.Workbooks.Open(myFullPath, , , , "読み取りパス", "書き込みパス")

　　エクセルに転記2 = 0
　　flg = flg Or myNewWbk
　　Resume Next

End Function

' ' ///

回答No.1

kagakusuki

開いてもいないExcelファイルのデータを保存するなどという事が果たして可能なのかどうかは存じませんが、

>いちいちExcelを開くのが手間なので

というだけの事なのでしたら、Wordのマクロの方に「Excelファイルを開くための構文」を付け加える事で、Wordのマクロを起動させるだけで自動的にExcelファイルを開く事が出来る様にする事も出来る筈ですが、それでは駄目なのでしょうか?
　一例としては次の様な形式のVBAの構文を使えばExcelファイルを開く事が出来ます。

With CreateObject("EXCEL.Application")
.Workbooks.Open "Excelファイルのパス(ファイル名自体も含む)"
.Visible = True
End With

お礼

kagakusukiさん、大変失礼いたしました。

下のほうに転記されていました。
今まで、転記できていたので、データーが入っているとは思ってもいませんでした。
削除したら、ちゃんと転記できました。
ありがとうございました。

補足

kagakusukiさん、いつもおありがとうございます。

開いていないファイルを保存することはできないのですね(^_^;)
検索しても全くヒットしなかったわけです。。。

ご提案のとおり、エクセルファイルを開くコードをあたまに追加しました。
ファイルが開いてカーソルはエクセル、ワードに戻ってメッセージボックスの、OKをクリックするのですが、転記ができなくなりました。

どうしたらいいのでしょうか？