保持排序范围内的第一个和最后一个
Option Explicit
Sub DeleteNotFirstNorLast()
Const ProcName As String = "DeleteNotFirstNorLast"
Dim RowsDeleted As Boolean ' to inform
On Error GoTo ClearError ' enable error trapping
' Constants (adjust!)
Const FirstCellAddress As String = "A1"
Const CriteriaColumnIndex As Long = 2
Const Criteria As String = "#$%"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Application.ScreenUpdating = False
' Turn off AutoFilter.
If ws.AutoFilterMode Then ws.AutoFilterMode = False
' Reference the table range.
Dim trg As Range: Set trg = RefCurrentRegion(ws.Range(FirstCellAddress))
' Write an ascending integer sequence adjacent to the right
' of the table range.
AppendColumnOfAscendingIntegers trg
' Include this helper column to the table range.
Set trg = trg.Resize(, trg.Columns.Count + 1)
' Reference the criteria column range.
Dim crg As Range: Set crg = trg.Columns(CriteriaColumnIndex)
' It is assumed that the criteria column is already sorted favorably.
' If not, you could do something like the following:
' Sort the table range by the criteria column ascending.
'trg.Sort crg, xlAscending, , , , , , xlYes
' Write the data rows (no headers) count to a variable.
Dim drCount As Long: drCount = trg.Rows.Count - 1
' Reference the criteria column data range (headers excluded).
Dim cdrg As Range: Set cdrg = crg.Resize(drCount).Offset(1)
' Write the values from the criteria column data range to an array.
Dim cData As Variant: cData = GetRange(cdrg)
' Replace the unwanted values in the array with the criteria.
KeepFirstAndLastInColumn cData
' Write the (modified) values from the array back to the range.
cdrg.Value = cData
' Reference the table data range (no headers).
Dim tdrg As Range: Set tdrg = trg.Resize(drCount).Offset(1)
' Filter the table range in the criteria column by the criteria.
trg.AutoFilter CriteriaColumnIndex, Criteria
' Attempt to reference the table data visible (filtered) range.
Dim tdvrg As Range
On Error Resume Next ' defer error trapping
Set tdvrg = tdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo ClearError ' re-enable error trapping
' Remove the filter.
ws.AutoFilterMode = False
' Attempt to delete the table data visible range.
If Not tdvrg Is Nothing Then
tdvrg.Delete xlShiftUp
RowsDeleted = True
End If
' Reference the helper column.
Dim hrg As Range: Set hrg = trg.Columns(trg.Columns.Count)
' Sort the table range by the helper column ascending.
trg.Sort hrg, xlAscending, , , , , , xlYes
' Clear the helper column.
hrg.Clear
SafeExit:
Application.ScreenUpdating = True ' to see any changes while reading message
' Inform.
If RowsDeleted Then
MsgBox "Rows deleted.", vbInformation, ProcName
Else
MsgBox "Nothing deleted.", vbExclamation, ProcName
End If
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume SafeExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns a reference to the range starting with the first cell
' of a range and ending with the last cell of the first cell's
' Current Region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegion( _
ByVal FirstCell As Range) _
As Range
Const ProcName As String = "RefCurrentRegion"
On Error GoTo ClearError
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1).CurrentRegion
Set RefCurrentRegion = FirstCell.Resize(.Row + .Rows.Count _
- FirstCell.Row, .Column + .Columns.Count - FirstCell.Column)
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Writes an ascending integer sequence adjacent to the right
' of a range.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub AppendColumnOfAscendingIntegers( _
ByVal trg As Range, _
Optional ByVal FirstInteger As Long = 1)
Const ProcName As String = "AppendColumnOfAscendingIntegers"
On Error GoTo ClearError
With trg
With .Resize(, 1).Offset(, .Columns.Count)
.Value = .Worksheet.Evaluate("ROW(" & CStr(FirstInteger) & ":" _
& CStr(FirstInteger + .Rows.Count - 1) & ")")
End With
End With
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('trg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal trg As Range) _
As Variant
Const ProcName As String = "GetRange"
On Error GoTo ClearError
If trg.Rows.Count + trg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = trg.Value
GetRange = Data
Else ' multiple cells
GetRange = trg.Value
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In the first column of a 2D one-based array of sorted values,
' keeps the first and last occurrence of each value and replaces
' the remaining occurrences with a string.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub KeepFirstAndLastInColumn( _
ByRef cData As Variant, _
Optional ByVal Criteria As String = "#$%")
Const ProcName As String = "KeepFirstAndLastInColumn"
On Error GoTo ClearError
Dim OldString As String: OldString = CStr(cData(1, 1))
Dim r As Long
Dim cr As Long
Dim FirstRow As Long
Dim NewString As String
For r = 2 To UBound(cData, 1)
NewString = CStr(cData(r, 1))
If NewString = OldString Then
If FirstRow = 0 Then
FirstRow = r
End If
Else
If FirstRow > 0 Then
For cr = FirstRow To r - 2
cData(cr, 1) = Criteria
Next cr
FirstRow = 0
End If
OldString = NewString
End If
Next r
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub