能否增加排序功能

湘喑 12天2小时前 :

这个动作主要目的就是快速汇总，如果要加个排序功能就要多弄个选项，就没这么快捷了

魔回复湘喑 12天0小时前 :

嗯。如果没有排序，我还是要手动排序。不过我用AI补充了代码，然后就有了排序。

魔回复湘喑 12天0小时前 :

'2024年8月28日15:54:10保存，添加了排序功能

Dim application, sh, rng, sortColIndex, sortOrder

Set application = GetObject(,"excel.application")

Set sh = application.activesheet

Set rng = application.selection

If rng.cells.count = 1 Then Set rng = rng.currentregion

On Error Resume Next

'------------------------------------------------------------------

Set rng = Application.Intersect(rng, sh.UsedRange)

If rng.Columns.Count = 2 Then '如果只选择了两列，那么自动判断字段列与汇总列

If IsNumeric(rng(3, 1)) Then

If IsNumeric(rng(3, 2)) Then

Set col = Application.InputBox("请选择汇总字段所在列", "Quicker提示！", , , , , , 8)

If Err Then WScript.Quit

ReDim zdrr(0): zdrr(0) = col.column

ReDim hzrr(0): hzrr(0) = 2*rng.Column+1-col.column

Else

ReDim zdrr(0): zdrr(0) = rng.Column + 1

ReDim hzrr(0): hzrr(0) = rng.Column

End If

ElseIf IsNumeric(rng(3, 2)) Then

ReDim zdrr(0): zdrr(0) = rng.Column

ReDim hzrr(0): hzrr(0) = rng.Column + 1

Else

MsgBox "无检测到汇总列，请选择正确的数据源"

WScript.Quit

End If

Set rng = sh.Range(sh.Cells(rng.Row, 1), rng(rng.Cells.Count))

arr = rng.Value

Else

Set rng = sh.Range(sh.Cells(rng.Row, 1), rng(rng.Cells.Count))

arr = rng.Value

'------------------------------------------------------------------记录字段所在列和汇总值所在列

Set rng = Application.InputBox("请选择汇总字段所在列（按住Ctrl键多选）", "Quicker提示！", , , , , , 8)

If Err Then WScript.Quit

k = 0

For Each col In rng.Columns

ReDim Preserve zdrr(k)

zdrr(k) = col.Column

k = k + 1

Set rng = Application.InputBox("请选择汇总值所在列（按住Ctrl键多选）", "Quicker提示！", , , , , , 8)

If Err Then WScript.Quit

For Each col In rng.Columns

ReDim Preserve hzrr(k)

hzrr(k) = col.Column

k = k + 1

End If

'------------------------------------------------------------------判断是否有标题，并创建标题数组

btrr = sh.Cells(1, 1).Resize(1, UBound(zdrr) + UBound(hzrr) + 2) '创建标题数组

If IsNumeric(arr(1, hzrr(0))) Then '如果数据源汇总列第一个单元格是数字，则默认为无标题，如果非数字则默认有标题

stari = 1

For i = 0 To UBound(zdrr)

k = k + 1

btrr(1, k) = "字段" & k

k = k + 1

btrr(1, k) = "汇总" & i + 1

stari = 2

For i = 0 To UBound(zdrr)

k = k + 1

btrr(1, k) = arr(1, zdrr(i))

k = k + 1

btrr(1, k) = arr(1, hzrr(i))

'------------------------------------------------------------------创建字典存储汇总数据

Set d = CreateObject("scripting.dictionary")

For i = stari To UBound(arr)

For j = 0 To UBound(zdrr)

zd = zd & "||" & CSTR(arr(i, zdrr(j)))

If d.exists(zd) Then

temprr = d(zd)

For j = 0 To UBound(hzrr)

temprr(j) = temprr(j) + arr(i, hzrr(j))

Else

temprr = hzrr

For j = 0 To UBound(hzrr)

temprr(j) = arr(i, hzrr(j))

End If

zd = ""

temprr = d.keys

jgrr = sh.Cells(1, 1).Resize(UBound(temprr) + 1, UBound(btrr, 2)).Value

For i = 1 To UBound(jgrr)

arr = Split(temprr(i - 1), "||")

For j = 0 To UBound(arr)

jgrr(i, j + 1) = arr(j)

For j = 0 To UBound(arr)

jgrr(i, UBound(zdrr) + 2 + j) = arr(j)

'------------------------------------------------------------------添加排序功能

If UBound(jgrr) > 1 Then '只有当数据行数大于1时才需要排序

'显示排序选项

Dim sortOptions, sortCol

sortOptions = "请选择排序依据列：" & vbCrLf

For i = 1 To UBound(btrr, 2)

sortOptions = sortOptions & i & ". " & btrr(1, i) & vbCrLf

sortColIndex = InputBox(sortOptions, "选择排序列", "1")

If Not IsNumeric(sortColIndex) Then

MsgBox "请输入有效的列序号"

WScript.Quit

End If

sortColIndex = CInt(sortColIndex)

If sortColIndex < 1 Or sortColIndex > UBound(btrr, 2) Then

MsgBox "排序列序号超出范围"

WScript.Quit

End If

'获取排序顺序

sortOrder = MsgBox("是否按升序排序？" & vbCrLf & "是：升序" & vbCrLf & "否：降序", vbYesNo, "选择排序顺序")

'执行排序

Call SortArray(jgrr, sortColIndex, sortOrder)

End If

'------------------------------------------------------------------保存结果

Set rng = Application.InputBox("请选择保存结果的位置", "Quicker提示！", , , , , , 8)

If Err Then WScript.Quit

rng.Resize(1, UBound(btrr, 2)).Value = btrr

rng.Offset(1).Resize(UBound(jgrr), UBound(jgrr, 2)).Value = jgrr

Set application = Nothing

Set sh = Nothing

Set rng = Nothing

Set d = Nothing

'------------------------------------------------------------------排序函数

Sub SortArray(arr, colIndex, order)

Dim i, j, temp

'冒泡排序实现

For i = 1 To UBound(arr) - 1

For j = 1 To UBound(arr) - i

'比较两个元素

If CompareValues(arr(j, colIndex), arr(j + 1, colIndex), order) Then

'交换行

For k = 1 To UBound(arr, 2)

temp = arr(j, k)

arr(j, k) = arr(j + 1, k)

arr(j + 1, k) = temp

End Sub

'------------------------------------------------------------------比较函数

Function CompareValues(val1, val2, order)

Dim result

'判断值的类型进行比较

If IsNumeric(val1) And IsNumeric(val2) Then

result = CDbl(val1) > CDbl(val2)

ElseIf IsDate(val1) And IsDate(val2) Then

result = CDate(val1) > CDate(val2)

Else

result = UCase(CStr(val1)) > UCase(CStr(val2))

End If

'根据排序顺序调整结果

If order = vbNo Then '降序

CompareValues = Not result

Else '升序

CompareValues = result

End If

End Function

湘喑回复魔 10天6小时前 :

666

能否增加排序功能

回复内容

回复主贴