將輸出存儲在臨時表單中進行排序

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