Sub Main() Dim a As String Dim i As Long, j As Long Dim last As Long last = Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To last a = Cells(i, 1) For j = 1 To last If i <> j Then a = CutWord(a, Cells(j, 1)) Next j Cells(i, 2) = a Next i End Sub
Function CutWord(a As String, b As String) As String Dim aa() As String Dim bb() As String Dim c As String Dim i As Long, j As Long aa = Split(a, " ") bb = Split(b, " ") For i = LBound(aa) To UBound(aa) For j = LBound(bb) To UBound(bb) If aa(i) = bb(j) Then Exit For Next j If j > UBound(bb) Then c = c & aa(i) & " " Next i CutWord = Trim(c) End Function
>>964 複数回現れる単語を削除すればいいのか？ Sub X964() Dim Sheet As Worksheet: Set Sheet = ... Dim Dictionary As Object: Set Dictionary = CreateObject("Scripting.Dictionary") Dim LastRow As Long: LastRow = SheetSheet.Cells(Rows.Count, "A").End(xlUp).Row Dim Row As Long For Row = 1 To LastRow Dim Word As Variant For Each Word In Split(Sheet.Cells(Row, "A").Value, " ") If Dictionary.Exists(Word) Then Dictionary(Word) = Dictionary(Word) + 1 Else Dictionary.Add Word, 1 End If Next Next For Row = 1 To LastRow Dim Uniques As String: Uniques = "" For Each Word In Split(Sheet.Cells(Row, "A").Value, " ") If 1 < Dictionary(Word) Then If Uniques = "" Then Uniques = Word Else Uniques = Uniques & " " & Word End If End If Next Sheet.Cells(Row, "B").Value = Uniques Next End Sub
Sub sample3() Dim r As Long Dim z As Long '最終行 Dim s As String '全データ Dim a() As String '単語リスト Dim i As Long z = Cells(Rows.Count, 1).End(xlUp).Row For r = 1 To z Cells(r, 2) = Cells(r, 1) s = s & Cells(r, 1) & " " Next r a = Split(s, " ") For i = LBound(a) To UBound(a) If Len(s) - Len(a(i)) > Len(Replace(s, a(i), "")) Then '2回以上出てくるか For r = 1 To z Cells(r, 2) = Trim(Replace(Cells(r, 2), a(i), "")) '各セルから削除 Next r End If Next i End Sub
