重複したコメントを削除して書き出すマクロ

質問

こんにちは、

先日、重複したコメントを削除するマクロの件で質問したのですが、またコメントの件で質問をお願いします。

Ａ列～Ｈ列の１～100行目までにコメントが入力されたセルがあります。コメントのいくつかは重複しています。列が違う場合は、同じコメントでも書き出し、かつ、列ごとにコメントを151行目以降に書き出したい（同じ列で重複している場合は繰り返し書き出さないが、列が異なる場合は、他の列にあっても書き出したい）のですが、どのようにしたらいいでしょうか？

例えばＡ列のコメントが1,2,3,4,5,3,4,5だと1,2,3,4,5と書き出し、Ｂ列のコメントが2,3,4,5,6,1,2,3だと1,2,3,4,5,6と書き出したいのです。

いろいろ試行錯誤したのですが、どうしてもうまくいかないのでよろしくお願いします。

回答No.1

Wendy02 · ベストアンサー

こんばんは。

本当は、他の方法でもよいとは思ったのですが、この前の続きで、ほとんど変えないまま、手を加えています。ほとんど、考えて作っていませんので、間違っていましたら、すみません。

-----------------------------------------------
'標準モジュール

Sub TestMacroR()
　　Dim rng As Range
　　Dim ar() As String
　　Dim ar2() As String
　　Dim cl As Range
　　Dim ret As Variant
　　Dim buf As String
　　Dim i As Long
Dim j As Long
　　Set rng = ActiveSheet.UsedRange
　　Application.ScreenUpdating = False
　　For Each cl In rng.Columns
　　　　ReDim ar(cl.Cells.Count - 1)
　　　　ReDim ar2(cl.Cells.Count - 1, 0)
　　　　For i = 1 To rng.Cells.Count
　　　　　　If Not cl.Cells(i).Comment Is Nothing Then
　　　　　　　　buf = WorksheetFunction.Clean(Trim(cl.Cells(i).Comment.Text))
　　　　　　　　On Error Resume Next
　　　　　　　　ret = 0
　　　　　　　　ret = WorksheetFunction.Match(buf, ar(), 0)
　　　　　　　　On Error GoTo 0
　　　　　　　　If ret = 0 Then
　　　　　　　　　　ar(i - 1) = buf
　　　　　　　　　　ar2(j, 0) = Mid$(buf, InStr(buf, ":") + 1)
　　　　　　　　　　j = j + 1
　　　　　　　　End If
　　　　　　　　buf = ""
　　　　　　End If
　　　　Next i
　　　　If j > 0 Then
　　　　　　'151行目から排出
　　　　　　With Cells(151, cl.Column).Resize(j)
　　　　　　　　.Value = ar2()
　　　　　　'並べ替え
　　　　　　　　.Sort Key1:=.Cells(1), _
　　　　　　　　　　　　　　 Order1:=xlAscending, _
　　　　　　　　　　　　　　 Header:=xlNo, _
　　　　　　　　　　　　　　 MatchCase:=False, _
　　　　　　　　　　　　　　 Orientation:=xlTopToBottom, _
　　　　　　　　　　　　　　 DataOption1:=xlSortNormal
　　　　　　End With
　　　　　　j = 0
　　　　End If
　　Next cl
　　　　Application.ScreenUpdating = True
　　　　Set rng = Nothing
End Sub

お礼

忙しい中、回答ありがとうございました。

教えていただいたマクロで思ったとおりの結果を得ることができました。たびたびありがとうございました。