如何用VBA 做个按钮按指定的规则重新排序

xptool · 发表于 2018-7-22 23:32

如何用VBA 做个按钮把表1A1:F12按指定的规则重新排序复制到表2

Book1.rar (9.08 KB, 下载次数: 26)

microyip · 发表于 2018-7-23 07:56

用正则抽出科*座*楼*区的*出来进行排序

microyip · 发表于 2018-7-23 09:58

Sub 排序()
Dim regExp As Object, oData As Object, vInfo As Variant
Dim vData As Variant, nRow As Integer, nCol As Integer, vRow As Variant
Dim vFill As Variant, nFill As Integer
Dim sAddress As String, nI As Integer
Dim dicAddress As Object
Dim vAddress As Variant, nAddress As Integer
vData = Sheet1.[A1].CurrentRegion.Value
If Not IsArray(vData) Then Exit Sub
If UBound(vData) = 1 Then Exit Sub
Application.ScreenUpdating = False
Set regExp = CreateObject("Vbscript.RegExp")
Set dicAddress = CreateObject("Scripting.Dictionary")
With regExp
.Global = True
.IgnoreCase = True
.Pattern = "科\S+座\S+楼\S+区"
For nRow = 2 To UBound(vData)
sAddress = vData(nRow, 3)
Set oData = .Execute(sAddress)
If oData.Count > 0 Then
vAddress = oData(0)
If Not dicAddress.Exists(vAddress) Then Set dicAddress(vAddress) = CreateObject("Scripting.Dictionary")
dicAddress(vAddress)(nRow) = 0
End If
Next
End With
vFill = Application.WorksheetFunction.Transpose(vData)
nFill = 1
With Sheet2
.UsedRange.ClearContents
If dicAddress.Count > 0 Then
If dicAddress.Count > 1 Then
vAddress = 升序排序(dicAddress.Keys())
Else
ReDim vAddress(0)
vAddress(0) = dicAddress.Keys()(0)
End If
End If
For nAddress = LBound(vAddress) To UBound(vAddress)
vRow = dicAddress(vAddress(nAddress)).Keys()
For nI = LBound(vRow) To UBound(vRow)
nFill = nFill + 1
For nCol = 1 To UBound(vFill)
vFill(nCol, nFill) = vData(vRow(nI), nCol)
Next
Next
Next
.[A1].Resize(nFill, UBound(vFill)) = Application.WorksheetFunction.Transpose(vFill)
End With
Application.ScreenUpdating = True
End Sub
Private Function 升序排序(ByVal vData As Variant) As Variant
Dim nI As Double, nJ As Double, vTmp As Variant
nJ = LBound(vData)
For nI = LBound(vData) To UBound(vData) - 1
If vData(nI) <= vData(nI + 1) Then
If nI > nJ Then
nJ = nI
Else
nI = nJ
End If
Else
vTmp = vData(nI)
vData(nI) = vData(nI + 1)
vData(nI + 1) = vTmp
If nI <> LBound(vData) Then nI = nI - 2
End If
Next nI
升序排序 = vData
End Function

复制代码

microyip · 发表于 2018-7-23 09:59

附上附件以供参考

xptool · 发表于 2018-7-23 16:50

挺快的准确无误

duquancai · 发表于 2018-7-23 22:00

本帖最后由 duquancai 于 2018-7-23 22:50 编辑

Sub mySort()
Dim js As Object, s$, sr$, f$
a = Sheet1.[A1].CurrentRegion.Value
Set js = CreateObject("MSScriptControl.ScriptControl")
js.Language = "JavaScript"
For i = 2 To UBound(a)
For j = 1 To UBound(a, 2)
If j = 1 Then s = "'" & a(i, j) & "'" Else: s = s & "," & "'" & a(i, j) & "'"
Next
sr = sr & "," & "[" & s & "]": s = Empty
Next
sr = "[" & Mid(sr, 2) & "]"
f = "function(x,y){i=r.exec(x[2]);j=r.exec(y[2]);return (i[1]==j[1])?((i[2]==j[2])?(o[i[3]]-o[j[3]]):(i[2]-j[2])):(i[1].localeCompare(j[1]))}"
js.eval ("r=/([A-Z]+)\D*(\d+)[^东南西北]*([东南西北])/;o={'东':4,'西':3,'南':2,'北':1};a=" & sr & ";a.sort(" & f & ")")
For i = 2 To UBound(a)
For j = 1 To UBound(a, 2)
a(i, j) = js.eval("a[" & i - 2 & "][" & j - 1 & "]")
Next
Next
Sheet2.Cells.Clear
Sheet2.Range("a1").Resize(UBound(a), UBound(a, 2)) = a
End Sub

复制代码

小花鹿 · 发表于 2018-7-23 22:37

楼主得到了两位高手的帮助

duquancai · 发表于 2018-7-24 14:12

本帖最后由 duquancai 于 2018-7-24 14:22 编辑

小花鹿发表于 2018-7-23 22:37
楼主得到了两位高手的帮助

我之所以做这个题目，是因为用数组在内存中排序：1.提取部分字符排序，2.有数字的排序，3.有字符串的排序，4.更是有自定义序列的排序。综合性较强！

LMY123 · 发表于 2018-7-24 17:21

正则表达式

		自动登录	找回密码
密码			免费注册

[求助] 如何用VBA 做个按钮按指定的规则重新排序

评分

评分

评分