Vba:删除列表中未提及的excel表(列表仅包含数值)

Question

我需要删除给定列表中未提及的表(范围为A7:A350)。我发现这个vba，但问题是它从我的工作簿中删除了所有的工作表，也许是因为工作表名是数字。我将非常感谢你的帮助。

Sub Deletenotinlist()
Dim i As Long
Dim cnt As Long
Dim xWb, actWs As Worksheet
Set actWs = ThisWorkbook.ActiveSheet
cnt = 0
Application.DisplayAlerts = False
For i = Sheets.Count To 1 Step -1
If Not ThisWorkbook.Sheets(i) Is actWs Then
xWb = Application.Match(Sheets(i).Name, actWs.Range("A7:A350"), 0)
If IsError(xWb) Then
ThisWorkbook.Sheets(i).Delete
cnt = cnt + 1
End If
End If
Next
Application.DisplayAlerts = True
If cnt = 0 Then
MsgBox "Not find the sheets to be seleted", vbInformation, "Kutools for Excel"
Else
MsgBox "Have deleted" & cnt & "worksheets"
End If

结束子

Answer 1

我想我会这样做。

Sub DeleteSheets()
Dim sht As Worksheet
Dim rng As Range
Set rng = Sheets("Sheet1").Range("A2:A10")
Application.DisplayAlerts = False
For Each sht In ActiveWorkbook.Worksheets
If Application.CountIf(rng, sht.Name) = 0 Then
sht.Delete
End If
Next sht
Application.DisplayAlerts = True
End Sub

Answer 2

您尝试做的事情可以通过多种方式完成，但我尝试调整您的代码，将缺失的表单名称放在数组中并在最后选择它们。如果选择方便，可以将Select替换为Delete:

Sub Deletenotinlist()
Dim i As Long, cnt As Long, xWb, actWs As Worksheet, lastR As Long, arrSh(), k As Long
Set actWs = ThisWorkbook.ActiveSheet
lastR = actWs.Range("A" & actWs.rows.count).End(xlUp).row
ReDim arrSh(ThisWorkbook.Sheets.count - 1)
cnt = 0
For i = 1 To Sheets.count
If Not ThisWorkbook.Sheets(i) Is actWs Then
xWb = Application.match(Sheets(i).Name, actWs.Range("A7:A" & lastR), 0)
If IsError(xWb) Then
arrSh(k) = CStr(ThisWorkbook.Sheets(i).Name): k = k + 1
cnt = cnt + 1
End If
End If
Next
ReDim Preserve arrSh(k - 1) 'keep only the filled array elements
Sheets(arrSh).Select 'You can replace 'Select' with 'Delete', if it returns correctly
If cnt = 0 Then
MsgBox "Not find the sheets to be seleted", vbInformation, "Kutools for Excel"
Else
MsgBox "Have deleted " & cnt & " worksheets"
End If
End Sub

处理A列:A中从第7行开始的所有现有值。

但恐怕您尝试处理的范围不包含任何现有的工作表名称…

为了测试上述假设，请运行下一个测试子，它将把所有现有的表名放在B列:B中，从第7行开始。然后删除一些行并运行前面的代码，替换"与"B"在lastR = actWs.Range("A" &...和actWs.Range("A7:A" & lastR)中代码应该选择所有缺失的表单:

Sub testArraySheets()
Dim arrSh, ws As Worksheet, k As Long

ReDim arrSh(ActiveWorkbook.Sheets.count - 1)
For Each ws In ActiveWorkbook.Sheets
If Not ws Is ActiveSheet Then
arrSh(k) = ws.Name: k = k + 1
End If
Next
ActiveSheet.Range("B7").Resize(UBound(arrSh) + 1, 1).Value = Application.Transpose(arrSh)
End Sub