정렬을위한 임시 시트에 출력 저장

Question

이 질문에이어서 Defining a range from values in another range (thanks Siddharth!) 작업을 가장 짧은 날짜 순으로 나열하도록 코드를 편집하고 싶습니다. Siddharth와 간단한 이야기를 나누면서 가장 좋은 방법은 임시 시트를 삭제하기 전에 데이터가 들어있는 임시 시트를 만들고, 도착한 데이터로 정렬하고 메시지 상자를 만드는 것이라고 제안했습니다. 어떤 아이디어를 시작할 것인가? msg 문자열을 새 시트로 내보낼 수 있습니까? 아니면 시트에 저장할 변수가 다른 변수 여야합니까?

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