字符串操作VBA Excel

Question

我正在努力解決以下問題。 我想對輸入Col A進行以下操作，並在col B中產生輸出：

1.刪​​除重復項（很容易並且很容易完成）

2.從字符串中刪除前導和/或尾隨空格（這也很容易完成）

3.在同一個單元格中收集一個單詞的不同翻譯-避免重復（這很困難，我不知道如何處理此問題）要了解這一點，請看一下輸入/輸出示例。

輸入：

     A
 absolution 
 absolution 
 absolutism 
 absolutism, absolute rule 
  absolutist   
  absolutist   
 absorb 
 absorb 
 absorb, bind 
 absorb, take up 
 absorb 
 absorb, imbibe, take up 
 absorb, sorb 
 absorb, take up 
 absorb, take up 
 absorb, imbibe 
 absorb 
 absorb 
 absorber 
 absorber 
 absorber 

輸出：

  col  B
absolution
absolutism, absolute rule
absolutist
absorb, bind, imbibe, take up, sorb
absorber

我嘗試使用下面的代碼，但我停留在第三點/步驟

Option Explicit
Sub StrMac()
Dim wk As Worksheet
Dim i, j, l, m As Long
Dim strc, strd, fstrc, fstrd As String
Dim FinalRowC, FinalRowD As Long

Set wk = Sheet1

wk.Columns(1).Copy Destination:=wk.Columns(3)
wk.Columns(2).Copy Destination:=wk.Columns(4)

wk.Range("$C:$C").RemoveDuplicates Columns:=1, Header:=xlNo
wk.Range("$D:$D").RemoveDuplicates Columns:=1, Header:=xlNo


FinalRowC = wk.Range("C1048576").End(xlUp).Row
FinalRowD = wk.Range("D1048576").End(xlUp).Row


If FinalRowC >= FinalRowD Then
    j = FinalRowC
Else
    j = FinalRowD
End If

For i = 1 To j
    If wk.Range("C" & i).Text <> "" Then
        strc = wk.Range("C" & i).Text
        strc = Replace(strc, Chr(160), "")
        strc = Application.WorksheetFunction.Trim(strc)
        wk.Range("C" & i).Value = strc
    Else: End If

    If wk.Range("D" & i).Text <> "" Then
        strd = wk.Range("D" & i).Text
        strd = Replace(strd, Chr(160), "")
        strd = Application.WorksheetFunction.Trim(strd)
        wk.Range("D" & i).Value = strd
    Else: End If
Next i

Dim Cet, Det, Fet, Met, s As Variant
Dim newstr
Dim pos, cos As Long
s = 1

For i = 1 To j

     If wk.Range("D" & i).Text <> "" Then

        l = 2
        strd = wk.Range("D" & i).Text
        newstr = strd

        For m = i + 1 To j
            pos = 1100
            cos = 2300

            fstrd = wk.Range("D" & m).Text
            cos = InStr(1, fstrd, ",")
            pos = InStr(1, fstrd, strd, vbTextCompare)

            If wk.Range("D" & m).Text <> "" And Len(fstrd) > Len(strd) And m <= j And cos <> 2300 And pos = 1 Then
                l = 5
                        newstr = newstr & "," & fstrd
                        wk.Range("D" & m) = ""

            Else: End If

        Next m

        wk.Range("E" & s) = newstr
        s = s + 1
     Else: End If

Next i


End Sub

Answer 1

假設您的輸入是A列，而您希望B列中的輸出（如您的問題所述），則以下內容將為您工作：

Sub tgr()

    Dim ws As Worksheet
    Dim rData As Range
    Dim aData As Variant
    Dim vData As Variant
    Dim vWord As Variant
    Dim aResults() As String
    Dim sUnq As String
    Dim i As Long

    Set ws = ActiveWorkbook.Sheets("Sheet1")
    Set rData = ws.Range("A1", ws.Cells(Rows.Count, "A").End(xlUp))

    If rData.Cells.Count = 1 Then
        'Only 1 cell in the range, check if it's no blank and output it's text
        If Len(Trim(rData.Text)) > 0 Then ws.Range("B1").Value = WorksheetFunction.Trim(rData.Text)
    Else
        'Remove any extra spaces and sort the data
        With rData
            .Value = Evaluate("index(trim(" & .Address(external:=True) & "),)")
            .Sort .Cells, xlAscending, Header:=xlNo
        End With

        aData = rData.Value                             'Load all values in range to array
        ReDim aResults(1 To rData.Cells.Count, 1 To 1)  'Ready the results array

        For Each vData In aData
            'Get only unique words
            If InStr(1, vData, ",", vbTextCompare) = 0 Then
                If InStr(1, "," & sUnq & ",", "," & vData, vbTextCompare) = 0 Then
                    sUnq = sUnq & "," & vData
                    If i > 0 Then aResults(i, 1) = Replace(aResults(i, 1), ",", ", ")
                    i = i + 1
                    aResults(i, 1) = vData
                End If
            Else
                'Add unique different translations for the word
                For Each vWord In Split(vData, ",")
                    If InStr(1, "," & aResults(i, 1) & ",", "," & Trim(vWord) & ",", vbTextCompare) = 0 Then
                        aResults(i, 1) = aResults(i, 1) & "," & Trim(vWord)
                    End If
                Next vWord
            End If
        Next vData
    End If

    'Output results
    If i > 0 Then ws.Range("B1").Resize(i).Value = aResults

End Sub