Excel VBA 'On Error Resume Next' 导致重命名表标题出现问题

Question

我想遍历工作簿中的表格并重命名表格中的某些列标题，以启用高级筛选器来复制数据。目前，我使用On Error Resume Next 来避免在表中找不到该列时出现错误消息，然后转到下一个表。

虽然这个方法工作得很好，但是当我试图调整表格的范围时，它在代码的后面产生了问题。调整大小不起作用。在@HTH 的帮助下，很明显On Error Resume Next 是一些代码更改后的问题。

有没有办法修复On Error Resume Next，或者我应该使用不同的方法循环遍历表格并重命名标题，跳过没有这些特定标题的表格？

当前相关代码：

'Loop through and apply a change to all Tables in the Excel Workbook

Dim tbl As ListObject
Dim sht As Worksheet

'Loop through each sheet and table in the workbook
  For Each sht In wb.Worksheets
    For Each tbl In sht.ListObjects
        On Error Resume Next
            'rename headings
            tbl.ListColumns("Ranging").Name = "MS"
            tbl.ListColumns("Stock on Hand - Store").Name = "SOH"
        Next tbl
  Next sht

'Create Filter Criteria ranges
With MainWB.Worksheets.Add
    .Name = "FltrCrit"
    Dim FltrCrit As Worksheet
    Set FltrCrit = MainWB.Worksheets("FltrCrit")
End With

With FltrCrit
    Dim DerangedCrit As Range
    Dim DormantCrit As Range
    Dim OverstockCrit As Range
    Dim OutdatedCrit As Range
    Dim NegCrit As Range
    Dim myLastColumn As Long

    'Create Deranged Filter Criteria Range
    .Cells(1, "A") = "Deranged"
    .Cells(2, "A") = "MS"
    .Cells(3, "A") = "<>4"
    .Cells(2, "B") = "SOH"
    .Cells(3, "B") = "=0"

    'get last column, set range name
    With .Cells

        'find last column of data cell range
        myLastColumn = .Find(What:="*", After:=.Cells(2), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column

        'specify cell range
        Set DerangedCrit = .Range(.Cells(2, "A:A"), .Cells(3, myLastColumn))

    End With
End With

'Copy Filtered data to specified tables
Dim tblFiltered As ListObject
Dim copyToRng As Range, SDCRange As Range

'DERANGED
'Store Filtered table in variable
Set tblFiltered = wb.Worksheets("Deranged with SOH").ListObjects("Table_Deranged_with_SOH")

'Remove Filtered table Filters
tblFiltered.AutoFilter.ShowAllData

'Set Copy to range on Filtered sheet table
Set copyToRng = tblFiltered.HeaderRowRange
Set SDCRange = MainWB.Worksheets(2).ListObjects("Table_SDCdata").Range

'Use Advanced Filter
SDCRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=DerangedCrit, CopyToRange:=copyToRng, Unique:=False

'Resize filtered table to include new data
With wb.Worksheets("Deranged with SOH").Cells
        'find last row of source data cell range

        myLastRow = .Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 End With

With tblFiltered
        .Resize .HeaderRowRange.Resize(myLastRow - .HeaderRowRange.Rows(1).Row + 1)
End With

'Clear filter data on SDC
MainWB.Worksheets(2).ListObjects("Table_SDCdata").AutoFilter.ShowAllData

Answer 1

可以使用以下方法禁用错误处理程序：

  On Error GoTo 0

https://docs.microsoft.com/en-us/dotnet/visual-basic/language-reference/statements/on-error-statement

如果这导致进一步的问题，则可能是存在错误，但由于错误处理程序在过程的其余部分保持活动状态，因此代码正在恢复到下一行。以下将仅将错误处理程序应用于循环，然后您可以调试调整大小的问题：

  On Error Resume Next
    For Each sht In wb.Worksheets
      For Each tbl In sht.ListObjects
            'rename headings
            tbl.ListColumns("Ranging").Name = "MS"
            tbl.ListColumns("Stock on Hand - Store").Name = "SOH"
        Next tbl
    Next sht
  On Error GoTo 0

Answer 2

好的，我很快就把它搞定了，所以它可能不是万无一失的，但你可以写一个这样的辅助函数：

Public Function HeaderExists(table As ListObject, columnName As String) As Boolean
    On Error GoTo nope
    If Not table.ListColumns(columnName) Is Nothing Then
        HeaderExists = True
    End If
    Exit Function
nope:
    HeaderExists = False
End Function

然后将 OERN 行替换为

For Each tbl In sht.ListObjects
        'rename headings
    if HeaderExists(tbl, "Ranging") then
        tbl.ListColumns("Ranging").Name = "MS"
    end if
    if HeaderExists(tbl, "Stock on Hand - Store") then
        tbl.ListColumns("Stock on Hand - Store").Name = "SOH"
    end if
Next tbl

我没有检查这是否会弄乱您的程序中的其他任何内容，因为它很长，但它至少应该正确地重命名所有内容。