根据这个问题,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
最佳答案
这就是你正在尝试的吗?
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
关于excel - 将输出存储在临时表中以进行排序,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/10373682/