Question

如下图所示，我有电流输出和预期输出。第一件事是我有工作表SPLIT和Duplication. 我想要的是TextBox1由用户填写和输入。它将保存到No Duplicated Word和With Duplicated Word

的其他列中

在这张图片中，current output位于first input，所有数据插入都很顺利。但是在2nd input数据中，一切都失败了。如何使用此代码执行此操作？在预期的输出中，显示的图片显示它删除了重复的单词并保存了它，但仍然是financial word is not missing。

代码

Sub SplitText()
    Dim WArray As Variant
    Dim TextString As String
    Dim col_no_dup As Long
    Dim col_dup As Long
    Dim counter As Integer
    Dim sht_database As Worksheet

    With ThisWorkbook
        Set sht_database = .Sheets("Duplication")
        TextString = LCase(TextBox1)
    End With

    WArray = Split(TextString, " ") 'load array

    If (TextString = "") Then
        MsgBox ("Error: Pls Enter your data")
    End
    Else: End If

    'set column locations for duplicates/no duplicates
    col_no_dup = 1
    col_dup = 2

    With sht_database
    'Print whole array into duplicates column
    .Cells(Cells.Rows.Count,col_dup).End(xlUp).Offset(1,0).Resize(UBound(WArray)+ IIf(LBound(WArray) = 0, 1, 0)) = Application.Transpose(WArray)

    'Loop through array
    For i = LBound(WArray) To UBound(WArray)
        counter = 0
        lrow_no_dup = .Cells(Cells.Rows.Count, col_no_dup).End(xlUp).row
        For n = 1 To lrow_no_dup 'loop through and check each existing value in the no dup column
            If .Cells(n, col_no_dup).Value = WArray(i) Then
                counter = counter + 1 'account for each occurence
            Else: End If
        Next n
        If counter = 0 Then 'counter = 0 implies the value doesn't exist in the "No Duplicates" column
            .Cells(lrow_no_dup + 1, col_no_dup).Value = WArray(i)
        Else: End If
    Next i

    End With

    MsgBox ("Successfully inserted")
End Sub

Private Sub CommandButton1_Click()
    Call SplitText
End Sub

当前输出 预期输出

Answer 1

请尝试使用此功能。你的vba循环遍及整个范围。我认为你想要做的只是循环通过

Sub SplitText()
    Dim WArray As Variant
    Dim TextString As String
    Dim col_no_dup As Long
    Dim col_dup As Long
    Dim counter As Boolean
    Dim sht_database As Worksheet

    With ThisWorkbook
        Set sht_database = .Sheets("Duplication")
        TextString = LCase(sht_database.OLEObjects("TextBox1").Object.Text)
    End With

    WArray = Split(TextString, " ") 'load array

    If (TextString = "") Then
        MsgBox ("Error: Pls Enter your data")
        End
    End If

    'set column locations for duplicates/no duplicates
    col_no_dup = 1
    col_dup = 2

     With sht_database
        'Print whole array into duplicates column
        .Cells(Cells.Rows.Count, col_dup).End(xlUp).Offset(1, 0).Resize(UBound(WArray) + IIf(LBound(WArray) = 0, 1, 0)) = Application.Transpose(WArray)
        lrow_no_dup = .Cells(.Rows.Count, col_no_dup).End(xlUp).Row + 1
        'Loop through array
        For i = LBound(WArray) To UBound(WArray)
            counter = False
            For n = lrow_no_dup To lrow_no_dup + UBound(WArray) 'loop through and check each existing value in the no dup column
                If .Cells(n, col_no_dup).Value = WArray(i) Then
                    counter = True 'account for each occurence
                    Exit For
                End If
            Next n
            If counter = False Then 'counter = 0 implies the value doesn't exist in the "No Duplicates" column
                .Cells(lrow_no_dup + j, col_no_dup).Value = WArray(i)
                j = j + 1
            End If
        Next i
    End With

    MsgBox ("Successfully inserted")

End Sub
Private Sub CommandButton1_Click()
    Call SplitText
End Sub

Answer 2

Arraylist和Dictionaries是尝试删除重复项时的理想选择。

Sub SplitText()
    Dim LineUpEntries As Boolean
    Dim TextString As String
    Dim v As Variant
    Dim listDups As Object, listNoDups As Object
    Set listDups = CreateObject("System.Collections.Arraylist")
    Set listNoDups = CreateObject("System.Collections.Arraylist")

    'You need to adjust the Worksheet's name
    TextString = LCase(ThisWorkbook.Sheets("Split").TextBox1.value)

    For Each v In Split(TextString, " ")
        listDups.Add v
        If Not listNoDups.Contains(v) Then
            listNoDups.Add v
        End If
    Next

    'LineUpEntries = True 'Uncomment this line to line up the entries
    With ThisWorkbook.Sheets("Duplication")
        If LineUpEntries Then
            With .Cells(.Rows.Count, 2).End(xlUp).Offset(1, -1).Resize(listNoDups.Count)
                .value = Application.Transpose(listNoDups.ToArray)
                FormatRange .Cells
            End With
        Else
            With .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(listNoDups.Count)
                .value = Application.Transpose(listNoDups.ToArray)
                FormatRange .Cells
            End With
        End If
        With .Cells(.Rows.Count, 2).End(xlUp).Offset(1).Resize(listDups.Count)
            .value = Application.Transpose(listDups.ToArray)
            FormatRange .Cells
        End With
    End With

End Sub

Sub FormatRange(Target As Range)
    With Target
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    End With
End Sub

拆分文本并保存到不同的字段（无重复，重复）在Excel VBA中使用数组

2 个答案: