趣味プログラミングblog

---

ベースとしたのは、Wordの表をエクセルに書き出すマクロ。

「wordの表をエクセルに張り付ける」

Wordマクロにはエクセルオブジェクトがないので、アプリとブックを定義して、シートを指定して記述。


Dim xlApp As Object, myBook As Object
Set xlApp = CreateObject("Excel.Application")

Set myBook = xlApp.Workbooks.Open(ファイルパス) 



With myBook.sheets("01議事録")  'シート指定

     処理内容を記載
end with

---

今回のハマりポイントは、最終行の取得処理。
エクセルマクロで以下の記述が常套手段だけど、ワードマクロでエラーが出る。

Cells(xlApp.Rows.Count, "C").End(xlup).Row

よく考えたら、xlupってエクセルマクロで定義された定数だから、Wordマクロには定義されていないのね。

対策は以下の通り。

Cells(xlApp.Rows.Count, "C").End(-4162).Row
'定数：xlup=-4162     'https://shikumika.org/entry/word-vba-xlup

どうやらxlupの値は-4162らしい。


ひとまず目的の動作をすることを確認したけど、エクセルが編集中のときにどんなエラーが出るか、どう対策するかは今後の課題。


最後にグリップボードにファイル名を保存する処理を入れたけど、保存操作もだるいので推奨ファイル名で別名保存することにした。

そんな感じで、以下ソース。

---

Option Explicit
Const cnst所属課 = "xx課"
Const cnst文書管理番号ファイル = "xxx\文書番号管理簿.xlsx"

 

Sub ◆文書番号を取得する()
    
    Dim strToday As String: strToday = Format(Now, "YYYYMMDD")      'Year(Now) & Format(Month(Now), "00") & Format(Day(Now), "00") '
    Dim strContents As String: strContents = InputBox("本日の日付で文書番号を取得します。文書名を入力してください。", "文書名を入力", cnst所属課 & "打ち合わせ議事録_" & strToday)
    If strContents = "" Then Call errorEnd("キャンセルしました。")
    
    'エクセルオブジェクト
    Dim xlApp As Object, myBook As Object
    
    'Excelが起動中かどうかを判定
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    
    'Excelが起動していない場合にExcelを起動する
    If Err.Number <> 0 Then
        Err.Clear
        Set xlApp = CreateObject("Excel.Application")
        DoEvents
    End If
    On Error GoTo 0
    
    'xlApp.Visible = True
    Set myBook = xlApp.Workbooks.Open(cnst文書管理番号ファイル) 'ブックを開く
    
    With myBook.sheets("11議事録")  'シート指定
        Dim tarGyo As Long: tarGyo = .Cells(xlApp.Rows.Count, "C").End(-4162).Row + 1     '定数：xlup=-4162     'https://shikumika.org/entry/word-vba-xlup
        .Cells(tarGyo, "C") = strContents   '内容
        .Cells(tarGyo, "D") = Format(Now, "yyyy/mm/dd") '作成日
        .Cells(tarGyo, "E") = 名前(Environ("USERNAME"))   '担当者　ログインIDから取得
        Dim strRecoName As String: strRecoName = .Cells(tarGyo, "F")  '推奨ファイル名
        
        .Activate
        .Cells(tarGyo, "C").Select  '表示用に選択
        'Dim RC As Long: RC = MsgBox("文書番号を取得しました。保存して終了します。", vbOKCancel)
        'If RC = vbCancel Then errorEnd ("キャンセルしました。")
        myBook.Save
        myBook.Close
    End With
    
    'Call TextCopy(strRecoName)  'コピー
    'MsgBox "文書番号を取得し、以下の推奨ファイル名をクリップボードにコピーしました。" & Chr(10) & Chr(10) & strRecoName
    ActiveDocument.SaveAs2 ActiveDocument.Path & "\" & strRecoName
    
    'オブジェクト変数の解放
    Set myBook = Nothing
    Set xlApp = Nothing
  
End Sub

 

Function 名前(ユーザ名 As String) As String
    'Dim tmpName As String
    Select Case ユーザ名
        Case "700001":     名前 = "矢吹"
    Case Else
        名前 = "登録なし" & ユーザ名
    End Select
End Function

 

'クリップボードへコピー 'https://zero0nine.com/archives/3359    を改良
Sub TextCopy(sText As String)
    With CreateObject("Forms.TextBox.1")
       .MultiLine = True
       .Text = sText             'TextBoxへコピーする文字列設定
       .SelStart = 0
       .SelLength = .TextLength
       .Copy
    End With
End Sub
Sub errorEnd(msg)
    MsgBox msg
    End
End Sub