|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
小白解法,排序加数组
Sub kong()
t = Timer
Sheets("数据").[a1].CurrentRegion.Select
Selection.Sort key1:=Sheets("数据").Cells(1, 1), order1:=xlAscending, Header:=xlYes
arr = Sheets("数据").Range("a2:a" & Sheets("数据").Cells(Rows.Count, "a").End(3).Row).Value
Sheets("数据").[a1].CurrentRegion.Select
Selection.Sort key1:=Sheets("数据").Cells(1, 2), order1:=xlAscending, Header:=xlYes
brr = Sheets("数据").Range("b2:b" & Sheets("数据").Cells(Rows.Count, "b").End(3).Row).Value
Sheets("数据").Range("d:d").Select
Selection.Sort key1:=Sheets("数据").Cells(1, 4), order1:=xlAscending, Header:=xlYes
crr = Sheets("数据").Range("d2:d" & Sheets("数据").Cells(Rows.Count, "d").End(3).Row).Value
'''''本身不去重
Dim k, k1, a, c
If arr(1, 1) < brr(1, 1) Then
a = 0
k = 1
Do While k < UBound(arr) + 1
If arr(k, 1) >= brr(1, 1) Then Exit Do
k = k + 1
Loop
If arr(k, 1) > brr(UBound(brr), 1) Then c = 0
If arr(k, 1) < brr(UBound(brr), 1) Then
c = 1
k1 = 1
Do While k1 < UBound(brr) + 1
If brr(k1, 1) >= arr(k, 1) Then Exit Do
k1 = k1 + 1
Loop
End If
Else
a = 1
k = 1
Do While k < UBound(brr) + 1
If brr(k, 1) >= arr(1, 1) Then Exit Do
k = k + 1
Loop
If brr(k, 1) > arr(UBound(arr), 1) Then c = 0
If brr(k, 1) < arr(UBound(arr), 1) Then
c = 1
k1 = 1
Do While k1 < UBound(arr) + 1
If arr(k1, 1) >= brr(k, 1) Then Exit Do
k1 = k1 + 1
Loop
End If
End If
Dim kk
If a = 1 Then
If c = 0 Then
ReDim drr(1 To UBound(arr) + UBound(brr))
kk = 1
Do While kk < UBound(arr) + UBound(brr) + 1
If kk < k Then
drr(kk) = brr(kk, 1)
ElseIf kk >= k And kk <= UBound(arr) + k - 1 Then
drr(kk) = arr(kk - (k - 1), 1)
Else
drr(kk) = brr(kk - UBound(arr), 1)
End If
kk = kk + 1
Loop
End If
Else
If c = 0 Then
ReDim drr(1 To UBound(arr) + UBound(brr))
kk = 1
Do While kk < UBound(arr) + UBound(brr) + 1
If kk < k Then
drr(kk) = arr(kk, 1)
ElseIf kk >= k And kk <= UBound(brr) + k - 1 Then
drr(kk) = brr(kk - (k - 1), 1)
Else
drr(kk) = arr(kk - UBound(brr), 1)
End If
kk = kk + 1
Loop
End If
End If
If crr(1, 1) < drr(1) Then
a = 0
k = 1
Do While k < UBound(crr) + 1
If crr(k, 1) >= drr(1) Then Exit Do
k = k + 1
Loop
k1 = 1
Do While k1 < UBound(drr) + 1
If drr(k1) >= crr(k, 1) Then Exit Do
k1 = k1 + 1
Loop
Else
a = 1
k = 1
Do While k < UBound(drr) + 1
If drr(k) >= crr(1, 1) Then Exit Do
k = k + 1
Loop
k1 = 1
Do While k1 < UBound(crr) + 1
If crr(k1, 1) >= drr(k) Then Exit Do
k1 = k1 + 1
Loop
End If
Dim p, p1, p2, d
p2 = 0
If a = 0 Then
p = k1
p1 = k
Do While p < UBound(drr) + 1
d = 0
If drr(UBound(drr)) < crr(p1, 1) Then Exit Do
Do While p1 < UBound(crr) + 1
If drr(p) = crr(p1, 1) Then drr(p) = "": d = 1: Exit Do
If drr(p) < crr(p1, 1) Then Exit Do
p1 = p1 + 1
Loop
If d = 1 Then p2 = p2 + 1
p = p + 1
Loop
Debug.Print Timer - t
Dim hrr(), hh
p = 1
hh = 1
ReDim hrr(1 To UBound(drr) - p2, 1 To 1)
Do While p < UBound(drr) + 1
If drr(p) <> "" Then
hrr(hh, 1) = drr(p)
hh = hh + 1
End If
p = p + 1
Loop
End If
'''''''本身去重
'' arr = 去重(arr)
'' brr = 去重(brr)
'' crr = 去重(crr)
'' Dim k, k1, a, c
'' If arr(1) < brr(1) Then
'' a = 0
'' k = 1
'' Do While k < UBound(arr) + 1
'' If arr(k) >= brr(1) Then Exit Do
'' k = k + 1
'' Loop
'' If arr(k) > brr(UBound(brr)) Then c = 0
'' If arr(k) < brr(UBound(brr)) Then
'' c = 1
'' k1 = 1
'' Do While k1 < UBound(brr) + 1
'' If brr(k1) >= arr(k) Then Exit Do
'' k1 = k1 + 1
'' Loop
'' End If
'' Else
'' a = 1
'' k = 1
'' Do While k < UBound(brr) + 1
'' If brr(k) >= arr(1) Then Exit Do
'' k = k + 1
'' Loop
'' If brr(k) > arr(UBound(arr)) Then c = 0
'' If brr(k) < arr(UBound(arr)) Then
'' c = 1
'' k1 = 1
'' Do While k1 < UBound(arr) + 1
'' If arr(k1) >= brr(k) Then Exit Do
'' k1 = k1 + 1
'' Loop
'' End If
'' End If
'' Dim kk
'' If a = 1 Then
'' If c = 0 Then
'' ReDim drr(1 To UBound(arr) + UBound(brr))
'' kk = 1
'' Do While kk < UBound(arr) + UBound(brr) + 1
'' If kk < k Then
'' drr(kk) = brr(kk)
'' ElseIf kk >= k And kk <= UBound(arr) + k - 1 Then
'' drr(kk) = arr(kk - (k - 1))
'' Else
'' drr(kk) = brr(kk - UBound(arr))
'' End If
'' kk = kk + 1
'' Loop
'' End If
'' Else
'' If c = 0 Then
'' ReDim drr(1 To UBound(arr) + UBound(brr))
'' kk = 1
'' Do While kk < UBound(arr) + UBound(brr) + 1
'' If kk < k Then
'' drr(kk) = arr(kk)
'' ElseIf kk >= k And kk <= UBound(brr) + k - 1 Then
'' drr(kk) = brr(kk - (k - 1))
'' Else
'' drr(kk) = arr(kk - UBound(brr))
'' End If
'' kk = kk + 1
'' Loop
'' End If
'' End If
'' If crr(1) < drr(1) Then
'' a = 0
'' k = 1
'' Do While k < UBound(crr) + 1
'' If crr(k) >= drr(1) Then Exit Do
'' k = k + 1
'' Loop
'' k1 = 1
'' Do While k1 < UBound(drr) + 1
'' If drr(k1) >= crr(k) Then Exit Do
'' k1 = k1 + 1
'' Loop
'' Else
'' a = 1
'' k = 1
'' Do While k < UBound(drr) + 1
'' If drr(k) >= crr(1) Then Exit Do
'' k = k + 1
'' Loop
'' k1 = 1
'' Do While k1 < UBound(crr) + 1
'' If crr(k1) >= drr(k) Then Exit Do
'' k1 = k1 + 1
'' Loop
'' End If
'' Dim p, p1, p2, d
'' p2 = 0
'' If a = 0 Then
'' p = k1
'' p1 = k
'' Do While p < UBound(drr) + 1
'' d = 0
'' If drr(UBound(drr)) < crr(p1) Then Exit Do
'' Do While p1 < UBound(crr) + 1
'' If drr(p) = crr(p1) Then drr(p) = "": d = 1: Exit Do
'' If drr(p) < crr(p1) Then Exit Do
'' p1 = p1 + 1
'' Loop
'' If d = 1 Then p2 = p2 + 1
'' p = p + 1
'' Loop
'' Debug.Print Timer - t
'' Dim hrr(), hh
'' p = 1
'' hh = 1
'' ReDim hrr(1 To UBound(drr) - p2, 1 To 1)
'' Do While p < UBound(drr) + 1
'' If drr(p) <> "" Then
'' hrr(hh, 1) = drr(p)
'' hh = hh + 1
'' End If
'' p = p + 1
'' Loop
'' End If
Sheets("数据").Range("f2").Resize(UBound(hrr), 1) = hrr
Debug.Print Timer - t
End Sub
Function 去重(hm)
Dim h, h1, h2
h2 = 1
Dim hrr()
h = 1
Do While h < UBound(hm)
h1 = h
If h = 1 Then ReDim Preserve hrr(1 To h2): hrr(h2) = hm(1, 1)
Do While h1 < UBound(hm) + 1
If hm(h1, 1) > hm(h, 1) Then
h2 = h2 + 1
ReDim Preserve hrr(1 To h2): hrr(h2) = hm(h1, 1)
h = h1: Exit Do
End If
h1 = h1 + 1
Loop
Loop
去重 = hrr
End Function
|
-
|