将输出存储在临时表单中进行排序

Question

继续从这个问题开始，Defining a range from values in another range，（感谢Siddharth！）我想要编辑代码以按最短的天数顺序列出任务。有一个简短的评论与Siddharth聊天，他建议最好的方法是创建一个包含数据的临时表，在删除临时表之前按到达的数据进行排序并创建消息框。任何想法从哪里开始？我可以将味精字符串导出到新纸张，还是需要将其他变量存储在纸张中

Option Explicit 

Sub Notify() 
    Dim WS1 As Worksheet 
    Dim Chk As Range, FltrdRange As Range, aCell As Range 
    Dim ChkLRow As Long 
    Dim msg As String 
On Error GoTo WhatWentWrong 

Application.ScreenUpdating = False 

Set WS1 = Sheets("Ongoing") 

With WS1 
    ChkLRow = .Range("C" & Rows.Count).End(xlUp).Row 

    '~~> Set your relevant range here 
    Set Chk = .Range("A1:K" & ChkLRow) 

    '~~> Remove any filters 
    ActiveSheet.AutoFilterMode = False 

    With Chk 
     '~~> Filter, 
     .AutoFilter Field:=3, Criteria1:="NO" 
     '~~> Offset(to exclude headers) 
     Set FltrdRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible) 
     '~~> Remove any filters 
     ActiveSheet.AutoFilterMode = False 

     For Each aCell In FltrdRange 
      If aCell.Column = 8 And _ 
      Len(Trim(.Range("B" & aCell.Row).Value)) <> 0 And _ 
      Len(Trim(aCell.Value)) <> 0 Then 
       msg = msg & vbNewLine & _ 
         "Request for contractor code " & .Range("B" & aCell.Row).Value & _ 
         " dispensing month " & .Range("A" & aCell.Row).Value & _ 
         " has been in the cupboard for " & _ 
         DateDiff("d", aCell.Value, Date) & " days." 
      End If 
     Next 
    End With 
End With 

'~~> Show message 
MsgBox msg 
Reenter: 
Application.ScreenUpdating = True 
Exit Sub 
WhatWentWrong: 
MsgBox Err.Description 
Resume Reenter 
End Sub 

Answer 1

这是您正在尝试的吗？

Option Explicit 

Sub Notify() 
    Dim WS1 As Worksheet, TmpSht As Worksheet 
    Dim Chk As Range, FltrdRange As Range, aCell As Range 
    Dim ChkLRow As Long, TSLastRow As Long, i As Long 
    Dim msg As String 

    On Error Resume Next 
    Application.DisplayAlerts = False 
    Sheets("Alistair_Weir").Delete 
    Application.DisplayAlerts = True 
    On Error GoTo 0 

    On Error GoTo WhatWentWrong 

    Application.ScreenUpdating = False 

    Set WS1 = Sheets("Ongoing") 

    With WS1 
     ChkLRow = .Range("C" & Rows.Count).End(xlUp).Row 

     '~~> Set your relevant range here 
     Set Chk = .Range("A1:K" & ChkLRow) 

     '~~> Remove any filters 
     ActiveSheet.AutoFilterMode = False 

     With Chk 
      '~~> Filter, 
      .AutoFilter Field:=3, Criteria1:="NO" 
      '~~> Offset(to exclude headers) 
      Set FltrdRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible) 
      '~~> Remove any filters 
      ActiveSheet.AutoFilterMode = False 

      '~~> Add Temp Sheet 
      Set TmpSht = Sheets.Add 
      ActiveSheet.Name = "Alistair_Weir" 

      '~~> Copy required rows to temp sheet 
      TSLastRow = 1 
      For Each aCell In FltrdRange 
       If aCell.Column = 8 And _ 
       Len(Trim(.Range("B" & aCell.Row).Value)) <> 0 And _ 
       Len(Trim(aCell.Value)) <> 0 Then 
        WS1.Rows(aCell.Row).Copy TmpSht.Rows(TSLastRow) 
        TSLastRow = TSLastRow + 1 
       End If 
      Next 
     End With 
    End With 

    With TmpSht 
     '~~> Sort Data 
     .Columns("A:H").Sort Key1:=.Range("H1"), Order1:=xlAscending, Header:=xlGuess, _ 
     OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
     DataOption1:=xlSortNormal 

     '~~> Create the message 
     For i = 1 To TSLastRow - 1 

      msg = msg & vbNewLine & _ 
        "Request for contractor code " & .Range("B" & i).Value & _ 
        " dispensing month " & .Range("A" & i).Value & _ 
        " has been in the cupboard for " & _ 
        DateDiff("d", .Range("H" & i).Value, Date) & " days." 
     Next 

     '~~> Delete the temp sheet 
     Application.DisplayAlerts = False 
     .Delete 
     Application.DisplayAlerts = True 
    End With 

    '~~> Show message 
    MsgBox msg 
Reenter: 
    Application.ScreenUpdating = True 
    Exit Sub 
WhatWentWrong: 
    MsgBox Err.Description 
    Resume Reenter 
End Sub