excel - 如何使用 VBA 调整 Excel 中表格/ListObject 的大小

Question

如何使用ListObject.Resize方法从表格中删除空行和空列

Answer 1

• 初始表格行必须保持不变，并且结果范围必须重叠

如果表的UsedRange大于工作表的UsedRange:

• 左侧和右侧的空列将被删除(如果表格没有标题)
• 空行只会从底部删除

如果表的UsedRange小于工作表的UsedRange，则表将扩展为包括:

• 表UsedRange之外的所有列(左和右)
• 表格UsedRange下方的所有行

---

表 1 包含一个示例表 - VBA 代码:

Option Explicit

Public Sub resizeTables()

    resizeTableUsedRangeV1 ActiveSheet.ListObjects(1)

End Sub

---

模块 1:

• 版本 1 - 始终调整表格大小
• 版本 2 - 仅当表格UsedRange 与工作表UsedRange 不同时才调整表格大小

---

Option Explicit

Public Sub resizeTableUsedRangeV1(ByRef tbl As ListObject)
    Dim ws As Worksheet, ur As Range, maxCell As Range
    Dim fr As Long, lr As Long         'first and last row on worksheet (used range)
    Dim fc As Long, lc As Long         'first and last column on worksheet (used range)

    If Not tbl Is Nothing Then
        Set ws = tbl.Parent
        Set ur = ws.UsedRange
        Set maxCell = GetMaxCell(ur)
        fr = ur.Row
        fc = ur.Column
        lr = maxCell.Row
        lc = maxCell.Column
        tbl.Resize ws.Range(ws.Cells(tbl.DataBodyRange.Row, fc), ws.Cells(lr, lc))
    End If
End Sub

---

Public Sub resizeTableUsedRangeV2(ByRef tbl As ListObject)
    Dim ws As Worksheet, ur As Range, tblRng As Range, maxCell As Range
    Dim fr As Long, lr As Long         'first and last row on worksheet (used range)
    Dim fc As Long, lc As Long         'first and last column on worksheet (used range)
    Dim frTbl As Long, fcTbl As Long   'first row and column in table (used range)
    Dim lrTbl As Long, lcTbl As Long   'last row and column in table (used range)

    If Not tbl Is Nothing Then
        Set ws = tbl.Parent
        Set ur = ws.UsedRange
        Set tblRng = tbl.DataBodyRange

        Set maxCell = GetMaxCell(ur)

        fr = ur.Row
        fc = ur.Column
        lr = maxCell.Row
        lc = maxCell.Column

        frTbl = tblRng.Row
        fcTbl = tblRng.Column
        lrTbl = frTbl + tblRng.Rows.Count - 1
        lcTbl = fcTbl + tblRng.Columns.Count - 1

        If fc <> fcTbl Or lr <> lrTbl Or lc <> lcTbl Then
            'first row of a table can not change
            tbl.Resize ws.Range(ws.Cells(frTbl, fc), ws.Cells(lr, lc))
        End If
    End If
End Sub

---

Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range
    'It returns the last cell of range with data, or A1 if Worksheet is empty
    Const NONEMPTY As String = "*"

    Dim lRow As Range, lCol As Range

    If rng Is Nothing Then Set rng = Application.ThisWorkbook.ActiveSheet.UsedRange
    If WorksheetFunction.CountA(rng) = 0 Then
        Set GetMaxCell = rng.Parent.Cells(1, 1)
    Else
        With rng
            Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                   After:=.Cells(1, 1), _
                                   searchDirection:=xlPrevious, _
                                   searchOrder:=xlByRows)
            Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                   After:=.Cells(1, 1), _
                                   searchDirection:=xlPrevious, _
                                   searchOrder:=xlByColumns)
            Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
        End With
    End If
End Function