Question

我是VBA的新手，我正在努力处理一段代码，我希望有人可以提供帮助。我在工作簿1（ThisWorkbook）的工作表1中分别有一系列78个表，每个表有1列，分别命名为表A到表BZ。每个表都是相应命名范围的源，“_ TableA”到“_TableBZ”，我用它来驱动Sheet 2上的一系列相关下拉列表。

我已经找到了将Workbook 2中的值复制并粘贴到Workbook 1中78个表中的每个表中的代码，一次一个表，有效地刷新了相关下拉列表中的可用选项。如果从工作簿2粘贴的值的数量大于工作簿1中的表的大小，则工作簿1中的表将自动调整大小以适合更新的数据集。如果从工作簿2粘贴的值的数量小于工作簿1中的表的大小，则需要调整表的大小，以便在依赖的下拉列表中不显示空白值。

我首先尝试在复制/粘贴循环中包含调整表的大小，但似乎无法正确定义变量，并且在Range.Resize和ListObjects.Resize方法之间进行选择时遇到了困难。我现在尝试创建第二个循环来遍历所有表，并在完成所有复制/粘贴后一次调整一个。这两种方法有什么不同吗？

我可以使用以下代码调整表A的大小，但它不会在下一个循环（i = 2）中进展到表B.

Dim CurrentTable As ListObject
i = 1
Do
    ThisWorkbook.Activate
    Set CurrentTable = ActiveSheet.ListObjects(1)
    CurrentTable.Resize Range("N1:N10")
    i = i + 1
Loop Until i = 78

我还需要将每个表的大小调整为适当的行数，因此我尝试包含另一个范围变量。以下代码不会调整表A的大小，并在“CurrentTable.Resize Range（TableRange）”上给出了应用程序定义或对象定义的错误：

Dim TableRange As Range
Dim CurrentTable As ListObject
i = 1
Do
    ThisWorkbook.Activate
    Set CurrentTable = ActiveSheet.ListObjects(1)
    Set TableRange = Range(CurrentTable).Resize (CurrentTable.Range.Rows.Count, 1)
    CurrentTable.Resize Range(TableRange)
    i = i + 1
Loop Until i = 78

我认为Resize范围内的Rows.Count可能会搞乱它，但是Resize（CurrentTable.Range.Rows，1）给了我同样的错误。

所以我需要一些组合，将CurrentTable的大小调整为包含数据的行数，然后移动到系列中的下一个表。

任何建议都会非常感谢！

Answer 1

以前代码的更通用版本

Option Explicit

Public Sub resizeTables()
    Dim tbl As ListObject

    Application.ScreenUpdating = False
    For Each tbl In ActiveSheet.ListObjects
        cleanUpTable tbl
    Next
    Application.ScreenUpdating = True

End Sub

此Sub删除重复值并对表格第一列中的项目进行排序

Private Sub cleanUpTable(ByRef tbl As ListObject) 'fails if tbl is Nothing
    Dim ws As Worksheet, db As Range, ur As Range
    Dim fr As Long, lr As Long, fc As Long, dr As Long

    Set ws = tbl.Parent:    Set ur = ws.UsedRange:  Set db = tbl.DataBodyRange
    fc = db.Column:         fr = tbl.HeaderRowRange.Row

    lr = ws.Cells(ur.Row + ur.Rows.Count, fc).End(xlUp).Row

    If lr > db.Row + db.Rows.Count - 1 Then                             'check beyond tbl
        tbl.Resize ws.Range(ws.Cells(fr, fc), ws.Cells(lr, fc))
    End If

    tbl.HeaderRowRange(1).RemoveDuplicates Columns:=1, Header:=xlYes    'get unique values

    Set db = tbl.DataBodyRange
    dr = ws.Cells(db.Row + db.Rows.Count - 1, fc).End(xlUp).Row

    If dr > db.Row Then     'if table has more than 1 row, sort 1st column A-Z
        With tbl.Sort
            .SortFields.Clear
            .Header = xlYes
            .MatchCase = True
            .Orientation = xlTopToBottom
            .SortFields.Add Key:=tbl.HeaderRowRange(1), Order:=xlAscending
            .Apply
        End With
    Else
        If dr = 1 Then tbl.Resize ws.Range(ws.Cells(fr, fc), db.Cells(1))
    End If

    lr = ws.Cells(ur.Row, fc).End(xlDown).Row
    tbl.Resize ws.Range(ws.Cells(fr, fc), ws.Cells(lr, fc))
    ws.Range(ws.Cells(lr + 1, fc), ws.Cells(ur.Row + ur.Rows.Count, fc)).Delete xlShiftUp
End Sub

这是上面的Sub，但它没有排序或删除重复项：

Private Sub cleanUpTable(ByRef tbl As ListObject) 'fails if tbl is Nothing
    Dim ws As Worksheet, db As Range, ur As Range
    Dim fr As Long, lr As Long, fc As Long, dr As Long

    Set ws = tbl.Parent:    Set ur = ws.UsedRange:  Set db = tbl.DataBodyRange
    fc = db.Column:         fr = tbl.HeaderRowRange.Row

    lr = ws.Cells(ur.Row + ur.Rows.Count, fc).End(xlUp).Row

    If lr > db.Row + db.Rows.Count - 1 Then                             'check beyond tbl
        tbl.Resize ws.Range(ws.Cells(fr, fc), ws.Cells(lr, fc))
    End If

    lr = ws.Cells(ur.Row, fc).End(xlDown).Row
    tbl.Resize ws.Range(ws.Cells(fr, fc), ws.Cells(lr, fc))
    ws.Range(ws.Cells(lr + 1, fc), ws.Cells(ur.Row + ur.Rows.Count, fc)).Delete xlShiftUp
End Sub

使用可变行数调整工作表上的每个表的大小

1 个答案: