2

この質問に続いて、別の範囲の値から範囲を定義します（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
4

1 に答える 1

3

これはあなたがしようとしていることですか？

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
于 2012-04-29T18:51:04.363 に答える