excel吧 关注：281,653贴子：1,553,403
- 38回复贴，共1页
不感兴趣
开通SVIP免广告
默认你的数据是从a1单元格开始的40*40连续区域
Sub 问题()
Dim arr, brr, minv, minv2, a, b, c
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr, 1) * UBound(arr, 2), 1 To 2)
For a = 1 To UBound(arr, 1)
For b = 1 To UBound(arr, 2)
c = c + 1
brr(c, 1) = arr(a, b)
Next
Next
For a = 1 To UBound(brr, 1)
minv = brr(a, 1)
minv2 = brr(a, 1)
For b = a + 1 To UBound(brr, 1)
If brr(b, 1) < minv Then
minv = brr(b, 1)
c = b
End If
Next
If minv < brr(a, 1) Then
brr(a, 1) = brr(c, 1)
brr(c, 1) = minv2
End If
Next
c = 0
For a = 1 To UBound(arr, 1)
For b = 1 To UBound(arr, 2)
c = c + 1
arr(a, b) = brr(c, 1)
Next
Next
c = [a1].End(xlToRight).Column + 2
Cells(1, c).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub
Sub 问题()
Dim arr, brr, minv, minv2, a, b, c
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr, 1) * UBound(arr, 2), 1 To 2)
For a = 1 To UBound(arr, 1)
For b = 1 To UBound(arr, 2)
c = c + 1
brr(c, 1) = arr(a, b)
Next
Next
For a = 1 To UBound(brr, 1)
minv = brr(a, 1)
minv2 = brr(a, 1)
For b = a + 1 To UBound(brr, 1)
If brr(b, 1) < minv Then
minv = brr(b, 1)
c = b
End If
Next
If minv < brr(a, 1) Then
brr(a, 1) = brr(c, 1)
brr(c, 1) = minv2
End If
Next
c = 0
For a = 1 To UBound(arr, 1)
For b = 1 To UBound(arr, 2)
c = c + 1
arr(a, b) = brr(c, 1)
Next
Next
c = [a1].End(xlToRight).Column + 2
Cells(1, c).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub
凑合着用吧，用的是cells去排序，原本想做二维数组的选择排序的，但是没法记录行号。
40*40要10秒钟完成，
@black__殇，@不会VBA，@QQ47436528。@菠萝蜜
求助其他大佬
Sub 问题()
Dim minv, minv2 As Long
Dim arr, a, b, c, d, rr, bb
f = 1
rr = [a1].End(xlDown).row
bb = [a1].End(xlToRight).Column
For a = 1 To rr
For b = 1 To bb
minv = Cells(a, b).Value
minv2 = Cells(a, b).Value
Cells(a, b).Copy Cells(rr + 1, bb + 1)
For d = a To [a1].End(xlDown).row
For c = f To [a1].End(xlToRight).Column
If Cells(d, c).Value < minv Then
minv = Cells(d, c).Value
col = c
r = d
End If
Next
f = 1
Next
If minv < Cells(a, b).Value Then
Cells(r, col).Copy Cells(a, b)
Cells(rr + 1, bb + 1).Copy Cells(r, col)
End If
f = b + 1
Next
Next
Cells(rr + 1, bb + 1).Clear
End Sub
40*40要10秒钟完成，
@black__殇，@不会VBA，@QQ47436528。@菠萝蜜求助其他大佬
Sub 问题()
Dim minv, minv2 As Long
Dim arr, a, b, c, d, rr, bb
f = 1
rr = [a1].End(xlDown).row
bb = [a1].End(xlToRight).Column
For a = 1 To rr
For b = 1 To bb
minv = Cells(a, b).Value
minv2 = Cells(a, b).Value
Cells(a, b).Copy Cells(rr + 1, bb + 1)
For d = a To [a1].End(xlDown).row
For c = f To [a1].End(xlToRight).Column
If Cells(d, c).Value < minv Then
minv = Cells(d, c).Value
col = c
r = d
End If
Next
f = 1
Next
If minv < Cells(a, b).Value Then
Cells(r, col).Copy Cells(a, b)
Cells(rr + 1, bb + 1).Copy Cells(r, col)
End If
f = b + 1
Next
Next
Cells(rr + 1, bb + 1).Clear
End Sub
系统删贴好烦，我尽力了，我帮你艾特其他大神看看
Sub 问题()
Dim minv, minv2 As Long
Dim arr, a, b, c, d, rr, bb
f = 1
rr = [a1].End(xlDown).row
bb = [a1].End(xlToRight).Column
For a = 1 To rr
For b = 1 To bb
minv = Cells(a, b).Value
minv2 = Cells(a, b).Value
Cells(a, b).Copy Cells(rr + 1, bb + 1)
For d = a To [a1].End(xlDown).row
For c = f To [a1].End(xlToRight).Column
If Cells(d, c).Value < minv Then
minv = Cells(d, c).Value
col = c
r = d
End If
Next
f = 1
Next
If minv < Cells(a, b).Value Then
Cells(r, col).Copy Cells(a, b)
Cells(rr + 1, bb + 1).Copy Cells(r, col)
End If
f = b + 1
Next
Next
Cells(rr + 1, bb + 1).Clear
End Sub
Sub 问题()
Dim minv, minv2 As Long
Dim arr, a, b, c, d, rr, bb
f = 1
rr = [a1].End(xlDown).row
bb = [a1].End(xlToRight).Column
For a = 1 To rr
For b = 1 To bb
minv = Cells(a, b).Value
minv2 = Cells(a, b).Value
Cells(a, b).Copy Cells(rr + 1, bb + 1)
For d = a To [a1].End(xlDown).row
For c = f To [a1].End(xlToRight).Column
If Cells(d, c).Value < minv Then
minv = Cells(d, c).Value
col = c
r = d
End If
Next
f = 1
Next
If minv < Cells(a, b).Value Then
Cells(r, col).Copy Cells(a, b)
Cells(rr + 1, bb + 1).Copy Cells(r, col)
End If
f = b + 1
Next
Next
Cells(rr + 1, bb + 1).Clear
End Sub
不感兴趣
开通SVIP免广告
菠萝蜜 emm，来了来了，就是说，我的水平也就这样的代码了：
Sub SortAndCheckDuplicates()
Application.ScreenUpdating = False ' 禁用屏幕更新
Dim rng As Range
Dim sortedRng As Range
Dim i As Long
Dim j As Long
Dim temp As Variant
Dim cell As Range
Dim duplicates As Collection
' 创建一个集合来存储重复的数值
Set duplicates = New Collection
' 获取选定的区域
Set rng = Selection
' 检查是否有选中区域
If rng Is Nothing Then
MsgBox "请先选中要排序的区域！", vbExclamation
Exit Sub
End If
' 检查区域是否只包含数字
For Each cell In rng
If Not IsNumeric(cell.Value) Then
MsgBox "请选择只包含数字的区域！", vbExclamation
Exit Sub
End If
Next cell
' 排序整个数据区域
Set sortedRng = rng.CurrentRegion
' 使用气泡排序算法对整个数据区域进行排序
For i = 1 To sortedRng.Rows.Count * sortedRng.Columns.Count - 1
For j = 1 To sortedRng.Rows.Count * sortedRng.Columns.Count - i
If sortedRng.Cells(j) > sortedRng.Cells(j + 1) Then
temp = sortedRng.Cells(j).Value
sortedRng.Cells(j).Value = sortedRng.Cells(j + 1).Value
sortedRng.Cells(j + 1).Value = temp
End If
Next j
Next i
' 检查重复的数字
For Each cell In sortedRng
If Application.WorksheetFunction.CountIf(sortedRng, cell.Value) > 1 And Not IsInCollection(cell.Value, duplicates) Then
' 如果有重复的数字，并且尚未添加到集合中，将其添加到集合中
duplicates.Add cell.Value
End If
Next cell
' 显示提示框
If duplicates.Count > 0 Then
Dim dupl As Variant
Dim result As String
' 将集合中的数值添加到结果字符串中
For Each dupl In duplicates
result = result & dupl & "，"
Next dupl
result = Left(result, Len(result) - 1)
MsgBox "排序已完成！重复出现的数值有：" & result & "。", vbInformation
Else
MsgBox "排序已完成！没有重复出现的数值。", vbInformation
End If
Application.ScreenUpdating = True ' 重新启用屏幕更新
End Sub
' 检查一个值是否已经存在于集合中
Function IsInCollection(val As Variant, coll As Collection) As Boolean
Dim i As Long
On Error Resume Next
IsInCollection = False
For i = 1 To coll.Count
If coll(i) = val Then
IsInCollection = True
Exit Function
End If
Next i
End Function
处理时间确实有一点长，如果你想看起来很酷，那你可以把禁用屏幕更新和启用屏幕更新的那两段给注释掉。
Sub SortAndCheckDuplicates()
Application.ScreenUpdating = False ' 禁用屏幕更新
Dim rng As Range
Dim sortedRng As Range
Dim i As Long
Dim j As Long
Dim temp As Variant
Dim cell As Range
Dim duplicates As Collection
' 创建一个集合来存储重复的数值
Set duplicates = New Collection
' 获取选定的区域
Set rng = Selection
' 检查是否有选中区域
If rng Is Nothing Then
MsgBox "请先选中要排序的区域！", vbExclamation
Exit Sub
End If
' 检查区域是否只包含数字
For Each cell In rng
If Not IsNumeric(cell.Value) Then
MsgBox "请选择只包含数字的区域！", vbExclamation
Exit Sub
End If
Next cell
' 排序整个数据区域
Set sortedRng = rng.CurrentRegion
' 使用气泡排序算法对整个数据区域进行排序
For i = 1 To sortedRng.Rows.Count * sortedRng.Columns.Count - 1
For j = 1 To sortedRng.Rows.Count * sortedRng.Columns.Count - i
If sortedRng.Cells(j) > sortedRng.Cells(j + 1) Then
temp = sortedRng.Cells(j).Value
sortedRng.Cells(j).Value = sortedRng.Cells(j + 1).Value
sortedRng.Cells(j + 1).Value = temp
End If
Next j
Next i
' 检查重复的数字
For Each cell In sortedRng
If Application.WorksheetFunction.CountIf(sortedRng, cell.Value) > 1 And Not IsInCollection(cell.Value, duplicates) Then
' 如果有重复的数字，并且尚未添加到集合中，将其添加到集合中
duplicates.Add cell.Value
End If
Next cell
' 显示提示框
If duplicates.Count > 0 Then
Dim dupl As Variant
Dim result As String
' 将集合中的数值添加到结果字符串中
For Each dupl In duplicates
result = result & dupl & "，"
Next dupl
result = Left(result, Len(result) - 1)
MsgBox "排序已完成！重复出现的数值有：" & result & "。", vbInformation
Else
MsgBox "排序已完成！没有重复出现的数值。", vbInformation
End If
Application.ScreenUpdating = True ' 重新启用屏幕更新
End Sub
' 检查一个值是否已经存在于集合中
Function IsInCollection(val As Variant, coll As Collection) As Boolean
Dim i As Long
On Error Resume Next
IsInCollection = False
For i = 1 To coll.Count
If coll(i) = val Then
IsInCollection = True
Exit Function
End If
Next i
End Function
处理时间确实有一点长，如果你想看起来很酷，那你可以把禁用屏幕更新和启用屏幕更新的那两段给注释掉。
Sub 企鹅47436528()
Dim i, m, r, x, y, arr, n
arr = [a1].CurrentRegion
x = UBound(arr)
y = UBound(arr, 2)
Columns(y + 2).Resize(, y + 2).Delete
For i = 1 To y
Cells(1, i).Resize(x).Copy Cells(m + 1, y + 2)
m = Cells(Rows.Count, y + 2).End(3).Row
Next
Cells(1, y + 2).Resize(m).Sort Cells(1, y + 2), 1
n = 1
For i = 1 To m Step y
Cells(i, y + 2).Resize(y).Copy
Cells(n, y + 3).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
n = n + 1
Next i
Columns(y + 2).Delete
End Sub
Dim i, m, r, x, y, arr, n
arr = [a1].CurrentRegion
x = UBound(arr)
y = UBound(arr, 2)
Columns(y + 2).Resize(, y + 2).Delete
For i = 1 To y
Cells(1, i).Resize(x).Copy Cells(m + 1, y + 2)
m = Cells(Rows.Count, y + 2).End(3).Row
Next
Cells(1, y + 2).Resize(m).Sort Cells(1, y + 2), 1
n = 1
For i = 1 To m Step y
Cells(i, y + 2).Resize(y).Copy
Cells(n, y + 3).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
n = n + 1
Next i
Columns(y + 2).Delete
End Sub
