VB 找出两个文本框 不同内容
文本框text1 内容2011-1-1
2011-1-2
2011-1-3
……
文本框text2 内容
2011-1-1
2011-1-2
2011-1-4
2011-1-5
……
找出这两个文本框text1 text2 不同内容放入text3中
Option Explicit Private Sub Command1_Click() Dim iCount1 As Long, iCount2 As Long, iStrCount1 As Long, iStrCount2 As Long Dim iIndex1() As Long, iIndex2() As Long Dim iStr1() As String, iStr2() As String Dim TTT As Single iStr1() = Split(Text(0).Text, vbCrLf) iStrCount1 = UBound(iStr1) iStr2() = Split(Text(1).Text, vbCrLf) iStrCount2 = UBound(iStr2) TTT = Timer Call NotEqual(iStrCount1, iStr1(), iStrCount2, iStr2(), iCount1, iIndex1(), iCount2, iIndex2()) Label1.Caption = "数组 1 总数 = " & iStrCount1 + 1 & ", 不相同的项 = " & iCount1 + 1 & vbCrLf & _ "数组 2 总数 = " & iStrCount2 + 1 & ", 不相同的项 = " & iCount2 + 1 & vbCrLf & _ "耗时 = " & (Timer - TTT) * 1000 & " ms" Call ToList(List1, iCount1 + 1, iStr1(), iIndex1()) Call ToList(List2, iCount2 + 1, iStr2(), iIndex2()) Erase iIndex1(), iIndex2(), iStr1(), iStr2() End Sub Private Sub NotEqual(ByVal ArrCount1 As Long, ByRef Arr1() As String, ByVal ArrCount2 As Long, ByRef Arr2() As String, ByRef NotEqualCount1 As Long, ByRef NotEqualIndex1() As Long, ByRef NotEqualCount2 As Long, ByRef NotEqualIndex2() As Long) Dim Ind1 As Long, Ind2 As Long, P As Long Dim iPos1() As Long, iPos2() As Long Dim tempArr1() As String, tempArr2() As String tempArr1() = Arr1() tempArr2() = Arr2() Call InitArray(ArrCount1, iPos1()) Call ShellSort_String(ArrCount1, tempArr1(), iPos1()) Call InitArray(ArrCount2, iPos2()) Call ShellSort_String(ArrCount2, tempArr2(), iPos2()) ReDim NotEqualIndex1(ArrCount1) As Long, NotEqualIndex2(ArrCount2) As Long NotEqualCount1 = -1 NotEqualCount2 = -1 Do If tempArr1(Ind1) < tempArr2(Ind2) Then NotEqualCount1 = NotEqualCount1 + 1 NotEqualIndex1(NotEqualCount1) = iPos1(Ind1) Ind1 = Ind1 + 1 ElseIf tempArr1(Ind1) > tempArr2(Ind2) Then NotEqualCount2 = NotEqualCount2 + 1 NotEqualIndex2(NotEqualCount2) = iPos2(Ind2) Ind2 = Ind2 + 1 Else Ind1 = Ind1 + 1 Ind2 = Ind2 + 1 End If If Ind1 > ArrCount1 Then For P = Ind2 To ArrCount2 NotEqualCount2 = NotEqualCount2 + 1 NotEqualIndex2(NotEqualCount2) = iPos2(P) Next Exit Do End If If Ind2 > ArrCount2 Then For P = Ind1 To ArrCount1 NotEqualCount1 = NotEqualCount1 + 1 NotEqualIndex1(NotEqualCount1) = iPos1(P) Next Exit Do End If Loop Call ResetArray(NotEqualCount1, ArrCount1, NotEqualIndex1()) Call ResetArray(NotEqualCount2, ArrCount2, NotEqualIndex2()) Erase tempArr1(), tempArr2(), iPos1(), iPos2() End Sub Private Sub InitArray(ByVal Length As Long, Arr() As Long) Dim P As Long ReDim Arr(Length) As Long For P = 0 To Length Arr(P) = P Next End Sub Private Sub ResetArray(ByVal NewCount As Long, ByVal OldCount, Arr() As Long) If NewCount = -1 Then Erase Arr() Else If NewCount < OldCount Then ReDim Preserve Arr(NewCount) As Long Call ShellSort_Long(NewCount, Arr()) End If End Sub Private Sub ShellSort_Long(ByVal ArrCount As Long, ByRef Arr() As Long) Dim Distance As Long, iNext As Long, P As Long Dim iTemp As Long P = ArrCount + 1 Distance = 1 While (Distance <= P) Distance = 2 * Distance Wend Distance = Distance / 2 - 1 While Distance > 0 iNext = Distance While iNext <= ArrCount P = iNext Do If P >= Distance Then If Arr(P) < Arr(P - Distance) Then iTemp = Arr(P) Arr(P) = Arr(P - Distance) Arr(P - Distance) = iTemp P = P - Distance Else Exit Do End If Else Exit Do End If Loop iNext = iNext + 1 Wend Distance = (Distance - 1) / 2 Wend End Sub Private Sub ShellSort_String(ByVal ArrCount As Long, ByRef Arr() As String, ByRef Pos() As Long) Dim Distance As Long, iNext As Long, tePos As Long, P As Long Dim iTemp As String P = ArrCount + 1 Distance = 1 While (Distance <= P) Distance = 2 * Distance Wend Distance = Distance / 2 - 1 While Distance > 0 iNext = Distance While iNext <= ArrCount P = iNext Do If P >= Distance Then If Arr(P) < Arr(P - Distance) Then iTemp = Arr(P) Arr(P) = Arr(P - Distance) Arr(P - Distance) = iTemp tePos = Pos(P) Pos(P) = Pos(P - Distance) Pos(P - Distance) = tePos P = P - Distance Else Exit Do End If Else Exit Do End If Loop iNext = iNext + 1 Wend Distance = (Distance - 1) / 2 Wend End Sub Private Sub ToList(List As ListBox, ByVal Count As Long, Arr() As String, ArrIndex() As Long) Dim P As Long With List .Clear .Visible = False For P = 0 To Count - 1 .AddItem Arr(ArrIndex(P)) Next .Visible = True End With End Sub
[此贴子已经被作者于2022-8-27 10:49编辑过]