他社に送る書類からメモ・コメントを一時的に退避させる（3.退避の改修）

前回・前々回でExcelからコメントを一覧にして抽出して別ブックに退避して削除、退避したコメントの復元までを一応完成させた。

www.excellovers.com

www.excellovers.com

しかし実際に使ってみたりblogへのコメントを頂いて「コメントの退避」の内容を少し改修してみた。

コード

'##########################################
'#CommentExport
'#対象ブックの内の全シートを捜査。
'#コメントが１つでもあれば新規ブックを作成し、新規ブックにコメント情報を転記する。
'##########################################
Sub CommentExport()
     Dim myWS As Worksheet
     Dim myRng As Range
     Dim myRngs As Range
     Dim myWB As Workbook
     Dim CommentWB As Workbook
     Dim WBAddFlag As Boolean
     Dim i As Long
     
'###コメントのExport
Application.ScreenUpdating = False
     WBAddFlag = False
     Set myWB = ActiveWorkbook
     'コメントが１つでもあれば新規ブックを作成してコメント情報転記
     For Each myWS In myWB.Worksheets
          If myWS.Comments.Count > 0 Then
               If WBAddFlag = False Then
                    Set CommentWB = Workbooks.Add
                    i = 1
                    With CommentWB.Worksheets(1)
                         .Cells(i, 1).Value = "コメント"
                         .Cells(i, 2).Value = "シート名"
                         .Cells(i, 3).Value = "アドレス"
                         .Cells(i, 4).Value = "コメント内容"
                    End With
                    i = i + 1
                    WBAddFlag = True
               End If
               
               Dim c As Long
               For c = 1 To myWS.Comments.Count
                    myWS.Comments(c).Parent.Copy
                    With CommentWB.Worksheets(1)
                         .Cells(i, 1).PasteSpecial Paste:=xlPasteComments
                         .Cells(i, 2).Value = myWS.Comments(c).Parent.Parent.Name
                         .Cells(i, 3).Value = myWS.Comments(c).Parent.Address
                         .Cells(i, 4).Value = myWS.Comments(c).Text
                    End With
                    i = i + 1
               Next c
          End If
'###既存コメントの削除。念の為コメントアウト
'          myRngs.ClearComments
     Next
     
     If WBAddFlag Then
          CommentPittariMove CommentWB
          CommentWB.Worksheets(1).Cells.EntireColumn.AutoFit
          CommentWB.Worksheets(1).Cells.EntireRow.AutoFit
          
          Dim SaveFolderPath As String
          Dim SaveFileName As String
          Dim myFSO As FileSystemObject
          Set myFSO = New FileSystemObject
          SaveFileName = myFSO.GetBaseName(myWB.FullName)
          
          SaveFolderPath = IIf(myWB.Path = "", CurDir, myWB.Path)
          CommentWB.Close True, SaveFolderPath & "\" & SaveFileName & _
               "_comment" & WorksheetFunction.Text(Now(), "hhmmss") & ".xlsx"
          
          MsgBox "コメントを転記いたしました", vbInformation + vbOKOnly, "コメント転記"
     Else
          MsgBox "コメントが見つかりません", vbInformation + vbOKOnly, "コメント転記"
     End If
Application.ScreenUpdating = True
End Sub

改修点

①以前に作成したものはそれぞれのブックにコードを書く前提でしたが、今回はアドイン登録して右クリックから使用できる前提。

②コメントが１つ以上ある場合のみ退避用のブックを作成する

③コメントが記載されたセルを見つけるためにジャンプ機能を使用していたが、Commentコレクションから該当セルを取得する方法に変更

④一度も保存されていないブックへの対応追加

①に関しては特に対策は取っていませんが、右クリックから呼び出している自作アドインツールに登録して使用できることを確認済み。

②以前のVerでは「コメントがあるからこのマクロを使用しているはず」という前提で作成していたため、まずコメント退避用のブックを作成するようにしていました。

しかし実際に使える状態にしてみると、「コメントがブック内に存在しているかの確認」のために使用するパターンがある事に気が付きました。

その使い方をするのであれば、コメントが無い状態でマクロを使用するパターンもあり、またその場合に中身のないブックが量産されることになってしまいます。

そこで以下の条件を満たした場合に退避用ブックを作成するようにしました。

・コメントが１つ以上存在する

・WBAddFlag が False　である。

WBAddFlagは新規ブック作成判定用の変数です。マクロ起動時はFalseに設定されていて、一度コメント退避用ブックを作成するとTrueが代入され以降のブック作成を抑制します。

③以前のVerではジャンプ機能を利用してコメントが付与されたセルを検索していましたが、ジャンプ機能はシートが保護されている場合は使用できないという制限があるため、マクロの使用に支障が発生しました。

そこでCommentsコレクションに含まれるコメントを順番に処理していく方法に変更しました。

④以前のVerでは一度も保存していないブックに対してマクロを実行すると、ブック自身のアドレスが設定されていないため、処理が止まってしまいました。

そこで未保存のブックの場合はカレントフォルダのパスを取得して、そこに新規ブックを保存する方法に変更しました。

その他

コードの中でもコメントアウトして使用不可にしていますが、ブック内のコメントをすべて削除する処理を外出にして別のマクロとして独立させました。

また以前に作成したぴったりコメントのマクロを同じく右クリックメニューに追加して使用できるようにしました。

まとめ

一旦完成させたものを実践に投入することでアラ探しをしてブラッシュアップすることができました。(blogで貴重なご意見も頂けました）

よく言われることですが、100％を求めて永遠の未完成でいるよりかは、70％でもどこかでケリを付けて完成（使用・発表）するのが大事ですね。

恐れずに発表するように心がけていきます。