excel吧 关注：282,238贴子：1,558,956
- 15回复贴，共1页
不感兴趣
开通SVIP免广告
菠萝蜜
Option Explicit
Sub abc()
Dim a, b, i, j, k, p, m, n
a = Range("a1:b" & [b1].End(xlDown).Row + 1).Value
ReDim pos(1 To UBound(a), 1 To 3)
For i = 1 To UBound(a) - 1
If Len(a(i + 1, 1)) Or i = UBound(a) - 1 Then
m = m + 1
pos(m, 1) = a(p + 1, 1): pos(m, 2) = p + 1: pos(m, 3) = i
p = i
End If
Next
Call bsort(pos, 1, m, 1, 3, 1)
b = a: p = 0
For i = 1 To m
For j = pos(i, 2) To pos(i, 3)
n = n + 1
For k = 1 To UBound(a, 2)
b(n, k) = a(j, k)
Next
Next
Call bsort(b, p + 1, n, 2, UBound(b, 2), 2)
p = n
Next
[d1].Resize(UBound(b), 2) = b
End Sub
Function bsort(a, first, last, left, right, key)
Dim i, j, k, t
For i = first To last - 1
For j = first To last + first - 1 - i
If a(j, key) > a(j + 1, key) Then
For k = left To right
t = a(j, k): a(j, k) = a(j + 1, k): a(j + 1, k) = t
Next
End If
Next
Next
End Function
看着长，但是运行很快哦！！~~~
Sub 问题()
Dim r, r2, a, b, c, d, m
Dim m1, m2 As Long
r = Cells(Rows.Count, 1).End(xlUp).row
r2 = Cells(Rows.Count, 2).End(xlUp).row
arr = Range("b1:b" & r2)
For a = 1 To r2
m1 = arr(a, 1)
m2 = arr(a, 1)
For b = a + 1 To r2
If arr(b, 1) < m1 Then
m1 = arr(b, 1)
c = b
End If
Next
If m1 < arr(a, 1) Then
arr(a, 1) = arr(c, 1)
arr(c, 1) = m2
End If
Next
[e1].Resize(r2, 1) = arr
ReDim brr(1 To r, 1 To 2)
b = 1
For a = 1 To r
m = Cells(a, 1).MergeArea.Count
If m > 1 Then
brr(b, 1) = Cells(a, 1).Value
Cells(a, 4).Resize(m).Merge
a = a + m - 1
b = b + 1
Else
brr(b, 1) = Cells(a, 1).Value
b = b + 1
End If
Next
b = b - 1
For a = 1 To b
m1 = brr(a, 1)
m2 = brr(a, 1)
For c = a + 1 To b
If brr(c, 1) < m1 Then
m1 = brr(c, 1)
d = c
End If
Next
If m1 < brr(a, 1) Then
brr(a, 1) = brr(d, 1)
brr(d, 1) = m2
End If
Next
b = 1
For a = 1 To r
m = Cells(a, 4).MergeArea.Count
If m > 1 Then
Cells(a, 4).Value = brr(b, 1)
b = b + 1
a = a + m - 1
Else
Cells(a, 4).Value = brr(b, 1)
b = b + 1
End If
Next
End Sub
Sub 问题()
Dim r, r2, a, b, c, d, m
Dim m1, m2 As Long
r = Cells(Rows.Count, 1).End(xlUp).row
r2 = Cells(Rows.Count, 2).End(xlUp).row
arr = Range("b1:b" & r2)
For a = 1 To r2
m1 = arr(a, 1)
m2 = arr(a, 1)
For b = a + 1 To r2
If arr(b, 1) < m1 Then
m1 = arr(b, 1)
c = b
End If
Next
If m1 < arr(a, 1) Then
arr(a, 1) = arr(c, 1)
arr(c, 1) = m2
End If
Next
[e1].Resize(r2, 1) = arr
ReDim brr(1 To r, 1 To 2)
b = 1
For a = 1 To r
m = Cells(a, 1).MergeArea.Count
If m > 1 Then
brr(b, 1) = Cells(a, 1).Value
Cells(a, 4).Resize(m).Merge
a = a + m - 1
b = b + 1
Else
brr(b, 1) = Cells(a, 1).Value
b = b + 1
End If
Next
b = b - 1
For a = 1 To b
m1 = brr(a, 1)
m2 = brr(a, 1)
For c = a + 1 To b
If brr(c, 1) < m1 Then
m1 = brr(c, 1)
d = c
End If
Next
If m1 < brr(a, 1) Then
brr(a, 1) = brr(d, 1)
brr(d, 1) = m2
End If
Next
b = 1
For a = 1 To r
m = Cells(a, 4).MergeArea.Count
If m > 1 Then
Cells(a, 4).Value = brr(b, 1)
b = b + 1
a = a + m - 1
Else
Cells(a, 4).Value = brr(b, 1)
b = b + 1
End If
Next
End Sub
