字符串操作VBA Excel

Question

我正在努力解決以下問題。 我想要做以下的輸入柱A的操作和產生列B輸出：

1.去除重複，如果任何（這是很容易完成）從

2.取出領導和/或尾隨空格字符串（這是很容易，以及它完成）

3.COLLECT一個詞以同一單元的不同的翻譯 - 避免重複（這很難，我不知道如何解決這個問題繼續進行） 要理解這一點看看輸入/輸出的例子。

輸入：

 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