物品尺寸排序问题

huang2006

有什么办法排序成表2里的形式，谢谢！

liulang0808

Sub 按钮1_Click()
    arr = [a1].CurrentRegion
    For j = 1 To UBound(arr)
        For I = j + 1 To UBound(arr)
            If Val(Split(arr(j, 2), "*")(1)) > Val(Split(arr(I, 2), "*")(1)) Then
                For X = 1 To 2
                    tm = arr(j, X)
                    arr(j, X) = arr(I, X)
                    arr(I, X) = tm
                Next X
            End If
        Next I
    Next j
    [h1].Resize(UBound(arr), UBound(arr, 2)) = arr
End Sub

liulang0808

附件内容供参考。。。。。。

huang2006

liulang0808 发表于 2020-3-17 19:31
附件内容供参考。。。。。。

如果物品名称多种的怎么排序？谢谢！

huang2006

boy8199

??? 你什么意思? 这需要 vba?

一把小刀闯天下

huang2006 发表于 2020-3-17 21:28
如果物品名称多种的怎么排序？谢谢！

Option Explicit

Sub test()
  Dim i, arr, s, t, p
  arr = Range("a1:c" & Cells(Rows.Count, "a").End(xlUp).Row + 1).Value
  Call qsort(arr, 1, UBound(arr, 1) - 1, 1, 2, 1)
  For i = 1 To UBound(arr, 1) - 1
    t = Split(arr(i, 2), "*")
    If UBound(t) > 0 Then s = Format(t(1), String(6, "0")) Else s = String(6, "0")
    arr(i, 3) = left(t(0), 1) & Format(Mid(t(0), 2), String(6, "0")) & s
    If arr(i, 1) <> arr(i + 1, 1) Then
      Call qsort(arr, p + 1, i, 1, UBound(arr, 2), 3)
      p = i
    End If
  Next
  [e1].Resize(UBound(arr, 1) - 1, 2) = arr
End Sub

Function qsort(arr, first, last, left, right, key)
  Dim i As Long, j As Long, k As Long, x As String, t As String
  i = first: j = last: x = arr((first + last) / 2, key)
  While i <= j
    While StrComp(arr(i, key), x, vbTextCompare) = -1: i = i + 1: Wend
    While StrComp(x, arr(j, key), vbTextCompare) = -1: j = j - 1: Wend
    If i <= j Then
      For k = left To right
        t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
      Next
      i = i + 1: j = j - 1
    End If
  Wend
  If first < j Then qsort arr, first, j, left, right, key
  If i < last Then qsort arr, i, last, left, right, key
End Function

renkangjizhen

代码随附件

huang2006

一把小刀闯天下 发表于 2020-3-18 09:17
Option Explicit

Sub test()

谢谢