Word ノートの結合 (VBA)
人からもらうノートが複数に分かれている場合がある。また勉強会のレジュメは通常複数ファイル。検索用に1つのファイルにしたいという要請はある。
これをうまく行うにはマクロが一番。自作マクロを公開しますので、気が向いたという奇特な方は、必要に応じて利用してみてください。インポートの仕方、マクロの動かし方などは、又時間ができたら書いてみますが、今はちょっと時間ができそうにもありません。
私もよく参考にさせていただいているmougというサイトがためになるかもしれません。
http://www.moug.net/
マクロを実行すると、（そしてうまくいくと）、全部つなげたファイルを一つ作ってくれます。各ファイルの変更履歴はそのまま結合版にも引き継がれます。各ファイルのヘッダ・フッタ情報は失われ、新たなヘッダ・フッタ（ページ番号）が付されます。
なお、これはウィルス騒ぎで標的にされたマクロです。思わぬ誤動作を引き起こす可能性（ないとは思いますが）があります。その点注意して自己責任で利用してください。私自身素人ですのでフォローは何もできません。コードもひどく汚く、自動記録に大いに頼っています。何かうまくいかないことがあればコメントしていただければ、できるだけ対処しますが、2年ほど前のものを、若干改訂して使っているので、当時何を思ったか正直良く思い出せない面もあります。また、誤動作を含め、なんらかの損害が発生しても一切責任を取るつもりはありません。あくまで自己責任でお願いします。
もし私を特定できた方（でかつ私のマクロを使ってみたいという相当奇特な方）は私個人宛にメールいただければ、その他マクロを収録したベース版(.doc)をお渡しすることも可能です。なお、そちらはダブルクリックしていただければこのマクロを含めたいくつかのマクロをインストールし、メニューへ追加する作業を自動でやってくれますので、うまく動けば気軽に試せます。
Sub ノート結合NIKKIMEMO()
'050605
MsgBox "ファイルの並び替えにエクセルを使用しています。" & Chr(13) & _
"うまく動作しない場合は、Alt + F11 で表示されるMicrosoft Visual Basic の画面で、" & Chr(13) & _
"ツール→参照から、エクセルを参照できる設定になっているか確認してください。" & Chr(13) & Chr(13) & _
"ファイルの結合は、ファイル名を昇順に並べた順序で行われます。" & Chr(13) & _
"思っている順番で結合されない場合は、ファイル名を工夫してください。" & Chr(13) & Chr(13) & _
"デスクトップのパスの取得にWSHを使用しています。" & Chr(13) & _
"うまく動作しない場合は、Alt + F11 で表示されるMicrosoft Visual Basic の画面で、" & Chr(13) & _
"ツール→参照から、Windows Script Host Object Model を参照できる設定になっているか確認してください。" & Chr(13) & Chr(13) & _
"★★元のヘッダ・フッタはすべて削除されます。"
Dim filenamae
filenamae = "NIKKIMEMO 結合ファイル" & Year(Now) & "_" & Month(Now) & "_" & Day(Now) & "_" & Hour(Now) & Minute(Now) & ".doc"
'デスクトップのパスを取得
'Windows Script Host Object Model に参照設定をする必要がある
Dim tempsavefolder As String
With New IWshRuntimeLibrary.Wshshell
tempsavefolder = .specialfolders("desktop")
End With
'結果表示用ファイルの作成
Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
ChangeFileOpenDirectory tempsavefolder
ActiveDocument.SaveAs FileName:=filenamae, FileFormat:=wdFormatDocument, _
LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False
'履歴を表示しない
With ActiveWindow.View
.ShowRevisionsAndComments = False
.RevisionsView = wdRevisionsViewFinal
End With
Documents(filenamae).Activate
'スタイルの設定
ActiveDocument.Styles.Add Name:="ファイル情報", Type:=wdStyleTypeParagraph
ActiveDocument.Styles("ファイル情報").AutomaticallyUpdate = False
With ActiveDocument.Styles("ファイル情報").Font
.NameFarEast = "ＭＳ 明朝"
.NameAscii = "Century"
.NameOther = "Century"
.Name = "Century"
.Size = 10.5
.Bold = True
.Italic = True
.Underline = wdUnderlineNone
.UnderlineColor = wdColorAutomatic
.StrikeThrough = False
.DoubleStrikeThrough = False
.Outline = False
.Emboss = False
.Shadow = False
.Hidden = False
.SmallCaps = False
.AllCaps = False
.Color = wdColorAutomatic
.Engrave = False
.Superscript = False
.Subscript = False
.Scaling = 100
.Kerning = 1
.Animation = wdAnimationNone
.DisableCharacterSpaceGrid = False
.EmphasisMark = wdEmphasisMarkNone
End With
With ActiveDocument.Styles("ファイル情報").ParagraphFormat
.LeftIndent = MillimetersToPoints(0)
.RightIndent = MillimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphJustify
.WidowControl = False
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = MillimetersToPoints(0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.AutoAdjustRightIndent = True
.DisableLineHeightGrid = False
.FarEastLineBreakControl = True
.WordWrap = True
.HangingPunctuation = True
.HalfWidthPunctuationOnTopOfLine = False
.AddSpaceBetweenFarEastAndAlpha = True
.AddSpaceBetweenFarEastAndDigit = True
.BaseLineAlignment = wdBaselineAlignAuto
End With
ActiveDocument.Styles("ファイル情報").NoSpaceBetweenParagraphsOfSameStyle = _
False
ActiveDocument.Styles("ファイル情報").ParagraphFormat.TabStops.ClearAll
With ActiveDocument.Styles("ファイル情報").ParagraphFormat
With .Shading
.Texture = wdTextureNone
.ForegroundPatternColor = wdColorAutomatic
.BackgroundPatternColor = wdColorAutomatic
End With
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Borders(wdBorderTop).LineStyle = wdLineStyleNone
.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
With .Borders
.DistanceFromTop = 1
.DistanceFromLeft = 4
.DistanceFromBottom = 1
.DistanceFromRight = 4
.Shadow = False
End With
End With
ActiveDocument.Styles("ファイル情報").LanguageID = wdEnglishUS
ActiveDocument.Styles("ファイル情報").NoProofing = False
ActiveDocument.Styles("ファイル情報").LanguageID = wdJapanese
ActiveDocument.Styles("ファイル情報").NoProofing = False
ActiveDocument.Styles("ファイル情報").Frame.Delete
Dim xls As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim CNT As Long
Dim myPath As String 'ワードファイルのパス
Dim myName As String 'ワードファイル名
'画面の設定
ActiveWindow.ActivePane.View.Type = wdPrintView
'画面更新をしない
With Application
.ScreenUpdating = False
.DisplayAlerts = wdAlertsNone
End With
'表示を消す
Selection.WholeStory
Selection.Delete
'エクセルを起動する
Dim DataFolderName As String
Dim DataFileName As String
Dim ActiveRow As Integer
'フォルダの選択
Dim openfolderdialog As FileDialog
Dim openfolderpath As String
Set openfolderdialog = Application.FileDialog( _
FileDialogType:=msoFileDialogFolderPicker)
openfolderdialog.InitialFileName = tempsavefolder & "\"
openfolderdialog.Title = "フォルダを選択するか、パスを貼り付けてください。キャンセルを押すとデスクトップが選択されます"
openfolderdialog.Show
On Error Resume Next
openfolderpath = tempsavefolder
openfolderpath = openfolderdialog.SelectedItems(1)
On Error GoTo 0
Dim カンマ5
If openfolderpath = tempsavefolder Then
カンマ5 = MsgBox("フォルダは、デスクトップでよろしいですか？", vbYesNo, "フォルダ")
If カンマ5 = vbNo Then
MsgBox "終了します。"
Exit Sub
End If
End If
DataFolderName = openfolderpath
'エクセルを実体化
Set xls = CreateObject("Excel.application")
Set wkb = xls.Workbooks.Add
Set wks = wkb.Worksheets(1)
'シートのクリア
wks.Range("A1:C65536").Select
xls.Selection.ClearContents
wks.Range("A1").Select
'ファイル名の表示
DataFileName = Dir(DataFolderName & "\" & "*.doc")
ActiveRow = 1
Do While DataFileName <> ""
wks.Cells(ActiveRow, 1) = DataFileName
DataFileName = Dir
ActiveRow = ActiveRow + 1
Loop
'並び替え
xls.Selection.Sort Key1:=wks.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
'フォルダ名の表示
wks.Rows("1:1").Select
xls.Selection.Insert Shift:=xlDown
wks.Range("A1").Select
xls.ActiveCell.FormulaR1C1 = DataFolderName
wks.Range("A2").Select
'つなげる作業
myPath = wks.Cells(1, 1).Text
'activate
If ActiveDocument.Name <> Documents(filenamae).Name Then
Documents(filenamae).Activate
End If
'目次のために余白を入れる
With Selection
.HomeKey Unit:=wdStory
.InsertBreak Type:=wdSectionBreakNextPage
.InsertBreak Type:=wdPageBreak
.Collapse Direction:=wdCollapseEnd
.MoveEnd Unit:=wdCharacter, Count:=-1
End With
For CNT = 2 To wks.Range("A65536").End(XLUP).Row
myName = wks.Cells(CNT, 1).Text
Selection.InsertFile _
FileName:=myPath & "\" & myName, _
Link:=False
'画面更新をしない
With Application
.ScreenUpdating = False
.DisplayAlerts = wdAlertsNone
End With
'セクション区切りにファイル名を入れる
With Selection
.InsertAfter "「" & myName & "」の末尾(NIKKIMEMO)"
'スタイルの設定
.Style = ActiveDocument.Styles("ファイル情報")
'アウトラインレベルの設定
.Range.Paragraphs.OutlineLevel = wdOutlineLevel1
'蛍光ペンを付ける
.Range.HighlightColorIndex = wdYellow
.Collapse Direction:=wdCollapseEnd
End With
'改ページ及び改セッションを入れる
Selection.InsertBreak Type:=wdSectionBreakContinuous
Selection.InsertBreak Type:=wdPageBreak
'画面更新をしない
Application.ScreenUpdating = False
Next CNT
'最後の改ページ等を消す
Selection.EndKey Unit:=wdStory
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
'画面更新をしない
Application.ScreenUpdating = False
'エクセル終了
xls.DisplayAlerts = False
xls.Quit
'ヘッダー
Dim para
With ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range
.Delete
.InsertAfter "[NIKKIMEMO 結合ファイル" & Date & "]"
.Paragraphs.Alignment = wdAlignParagraphRight
For Each para In .Paragraphs
para.Range.Font.Size = 10.5
para.Range.Font.Name = "MS明朝"
Next para
End With
'フッタ（ページの挿入）
Dim srange
Set srange = ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range
With srange
.Delete
.Fields.Add Range:=srange, Type:=wdFieldEmpty, Text:= _
"NUMPAGES \* Arabic ", PreserveFormatting:=True
.InsertAfter " / "
'選択範囲の変更
.Collapse Direction:=wdCollapseStart
.Fields.Add Range:=srange, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic ", PreserveFormatting:=True
.Paragraphs.Alignment = wdAlignParagraphCenter
For Each para In .Paragraphs
para.Range.Font.Size = 10.5
para.Range.Font.Name = "MS明朝"
Next para
End With
'ページ番号の整形
Dim s
For Each s In ActiveDocument.Sections
'１ページ目も同じ設定にする
s.PageSetup.DifferentFirstPageHeaderFooter = False
'前のセクションから続きにする
s.Footers(wdHeaderFooterPrimary).PageNumbers.RestartNumberingAtSection = False
Next s
'画面更新をしない
Application.ScreenUpdating = False
'本文選択
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Selection.HomeKey Unit:=wdStory
'画面更新をしない
Application.ScreenUpdating = False
'目次の追加（ファイル情報を目次として追加する）
Selection.HomeKey Unit:=wdStory
With Selection
.InsertAfter "各ファイルの末尾は下記のページのとおりです" & Chr(13) & _
"元のファイルのヘッダに記載の情報が失われていますので注意してください。" & Chr(13) & Chr(13)
.Collapse Direction:=wdCollapseEnd
End With
'自動記録によると、デフォルトで設定されている目次レベルのある書式を排除できない。
'デフォルトで行うとこのようなフィールドとなる TOC\o"1-9"\h\z\t"ファイル情報,1"
WordBasic.FormatField Field:="TOC \h \z \t ""ファイル情報"" "
ActiveWindow.View.ShowFieldCodes = False
'目次の更新
ActiveDocument.TrackRevisions = False
With ActiveWindow.View
.ShowRevisionsAndComments = False
.RevisionsView = wdRevisionsViewFinal
End With
Dim myTOC
For Each myTOC In ActiveDocument.TablesOfContents
myTOC.Update
Next
'履歴を表示する
With ActiveWindow.View
.ShowRevisionsAndComments = True
.RevisionsView = wdRevisionsViewFinal
End With
'ページだけ更新
For Each myTOC In ActiveDocument.TablesOfContents
myTOC.UpdatePageNumbers
Next
'画面設定戻す
With Application
.DisplayAlerts = wdAlertsAll
.ScreenUpdating = True
End With
ActiveDocument.Save
'問い合わせ
Dim Msg, Style, Title
Msg = "正常に完了しました。" & Chr(13) & Chr(13) & _
"デスクトップに「NIKKIMEMO 結合ファイル＜年月日＞.doc」という名称で保存してあります。" & Chr(13) & _
"このファイルは､検索・確認目的にのみ用いてください｡ " & Chr(13) & Chr(13) & _
"（Tips）" & Chr(13) & _
"● 通しのページ番号と、結合ファイル作成日時を付けてありますので、情報の特定にご利用ください。" & Chr(13) & Chr(13) & _
"● 元のファイルの履歴はそのまま履歴として表示されていますので、「次の履歴を表示」などで簡易に探せます。" & Chr(13) & Chr(13) & _
"● 複数の人の履歴がついているときは、フィルターを利用すると特定の人の履歴のみ表示できて便利です。" & Chr(13) & Chr(13) & _
"● 元のファイルの結合部分には改ページおよびセクション区切りを入れていますので、" & Chr(13) & _
" ワイルドカードを使用しない設定で、これらを検索する（「^b^m」と入力する）とファイルの先頭部分を容易に探せます。" & Chr(13) & Chr(13) & _
"文書を閉じますか？" ' メッセージを定義します。
Style = vbYesNo + vbQuestion + vbDefaultButton2 ' ボタンを定義します。
Title = "閉じますか？" ' タイトルを定義します。
' メッセージを表示します。
Response = MsgBox(Msg, Style, Title)
If Response = vbNo Then ' [いいえ] がクリックされた場合、
Exit Sub
End If
ActiveDocument.Close
End Sub
No comments:
Post a Comment