Question

我正在努力解决以下问题。我想对输入字母A执行以下操作，并在字段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

字符串操作VBA Excel

1 个答案: