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

如下图所示，我有“当前输出”和“期望输出”。 首先是我有工作表SPLIT和Duplication. 我想要的是TextBox1被用户填写和input。 它将被保存到No Duplicated Word和不With Duplicated Word

在这幅图中，在first input的current output中，所有的数据插入看起来都很好。 但是在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 

电stream输出 预期产出

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