求一个vba可以实现排序并将排序结果存入新表中

ghostsnack

1.排序思路，使用int(today（）-提交时间)+分数，然后按照计算结果降序排列。
2.最好是有一个生成按钮，点一下按钮将排列结果生成一个新的sheet名称为“结果”如果该sheet存在则删除旧sheet并生成新的名称为“结果”的sheet，sheet1中的数据顺序不变。
3.结果sheet中的内容是锁定的不允许修改。
感谢！！！

liulang0808

Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each sh In Sheets
        If sh.Name = "结果" Then
            sh.Delete
            Exit For
        End If
    Next sh
    Set sh = Sheets(1)

    Sheets(1).Copy after:=Sheets(1)
    Sheets(2).Name = "结果"
    r = Cells(Rows.Count, 1).End(3).Row
    arr = [a1].Resize(r, 4)
    For j = 2 To UBound(arr)
        arr(j, 4) = Date - arr(j, 2)
    Next j
    For j = 2 To UBound(arr)
        For i = j + 1 To UBound(arr)
            If arr(j, 4) < arr(i, 4) Then
                For x = 1 To UBound(arr, 2)
                    tm = arr(i, x)
                    arr(i, x) = arr(j, x)
                    arr(j, x) = tm
                Next x
            End If
        Next i
    Next j
    For Each shp In Sheets(2).Shapes
        shp.Delete
    Next shp
    [a1].Resize(r, 4) = arr
    Sheets(2).Protect
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

liulang0808

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

ghostsnack

liulang0808 发表于 2021-3-7 08:01
附件内容供参考。。。。。。

感谢版主大大

ghostsnack

liulang0808 发表于 2021-3-7 08:01
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

感谢版主大大

ghostsnack

liulang0808 发表于 2021-3-7 08:01
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

排序的结果可能不是很对，是不是日期运算那块有问题

liulang0808

ghostsnack 发表于 2021-3-7 11:11
排序的结果可能不是很对，是不是日期运算那块有问题

楼主按照目前附件反馈下具体哪里有出入？便于处理

lmgz007

使用int(today（）-提交时间)+分数，然后按照计算结果降序排列

这个思路我就觉得有点问题，或者是表达和理解不一致。

当家的MAX

Sub 按钮1_Click()
     Application.ScreenUpdating = False
     Application.DisplayAlerts = False
     For Each sh In Sheets
         If sh.Name = "结果" Then
             sh.Delete
             Exit For
         End If
     Next sh
     Set sh = Sheets(1)

     Sheets(1).Copy after:=Sheets(1)
     Sheets(2).Name = "结果"
     r = Cells(Rows.Count, 1).End(3).Row
     arr = [a1].Resize(r, 4)
     For j = 2 To UBound(arr)
         arr(j, 4) = Date - arr(j, 2) + arr(j, 3)
     Next j
     For j = 2 To UBound(arr)
         For i = j + 1 To UBound(arr)
             If arr(j, 4) < arr(i, 4) Then
                 For x = 1 To UBound(arr, 2)
                     tm = arr(i, x)
                     arr(i, x) = arr(j, x)
                     arr(j, x) = tm
                 Next x
             End If
         Next i
     Next j
     For Each shp In Sheets(2).Shapes
         shp.Delete
     Next shp
     [a1].Resize(r, 4) = arr
     Sheets(2).Protect
     Application.DisplayAlerts = True
     Application.ScreenUpdating = True
End Sub
版主的加上分数就可以了啊

准提部林

Sub TEST_A1()
Application.DisplayAlerts = False
On Error Resume Next
Sheets("结果").Delete
On Error GoTo 0
Sheets("Sheet1").Copy after:=Sheets(Sheets.Count)
With ActiveSheet
     .Name = "结果"
     .DrawingObjects.Delete
     .UsedRange.Sort Key1:=Range("B1"), Order1:=xlDescending, _
                     Key2:=Range("C1"), Order2:=xlDescending, Header:=xlYes
    .Protect
End With
End Sub