包含数据的所有行的Excel VBA“格式为表格”

Question

所以我创建了以下带有记录功能的宏：

ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1:L656"), , xlYes).Name = _
    "Table1"
Range("Table1[#All]").Select
ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight15"
ActiveWindow.SmallScroll Down:=-21

宏将“格式化为表格”整个表格，但不是记录选择包含数据的所有行（就像我使用 shift + 箭头键所做的那样），它记录了绝对选择 我需要它来选择从 A1 到 L 的所有内容（最后占用的行数） 我有一个解决方案，但我把它弄丢了，再也找不到了。

提前谢谢你！

Answer 1

将范围转换为表格

Option Explicit

Sub ConvertRangeToTable()
    
    ' Define constants.
    Const FirstRowAddress As String = "A1:L1"
    Const tblName As String = "Table1"
    Const tblStyleString As String = "TableStyleLight15"
     
    ' Attempt to create a reference to the worksheet.
    If ActiveSheet Is Nothing Then Exit Sub
    If ActiveSheet.Type <> xlWorksheet Then Exit Sub
    Dim ws As Worksheet: Set ws = ActiveSheet
    
    ' Attempt to create a reference to the range.
    Dim rg As Range
    With ws.Range(FirstRowAddress)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If lCell Is Nothing Then Exit Sub
        Set rg = .Resize(lCell.Row - .Row + 1)
    End With
    
    ' Attempt to create a reference to the table.
    Dim tbl As ListObject
    On Error Resume Next
    Set tbl = ws.ListObjects(tblName)
    On Error GoTo 0
    
    ' If the table already exists, 'unlist' it.
    If Not tbl Is Nothing Then
        tbl.Unlist
    End If
    
    ' Convert the range to the table.
    Set tbl = ws.ListObjects.Add(xlSrcRange, rg, , xlYes)
    With tbl
        .Name = tblName
        .TableStyle = tblStyleString
    End With
    
    ' Clear the range below the table.
    With rg
        .Resize(.Worksheet.Rows.Count - .Row - .Rows.Count + 1) _
            .Offset(.Rows.Count).Clear
    End With

    ' Inform user of success.
    MsgBox "Created table '" & tblName & "' for the range '" _
        & rg.Address(0, 0) & "'.", vbInformation, "Convert Range to Table"

End Sub

Answer 2

试试这个代码：

ActiveSheet.ListObjects.Add(xlSrcRange, _
            Range("A1").CurrentRegion, XlListObjectHasHeaders:=xlYes, _
            TableStyleName:="TableStyleLight15").Name = "Table1"

之前

之后（如果某些列没有标题，则会创建它们）

旁注：为防止与表名和/或范围冲突相关的错误（您不能在同一张表上创建具有相同名称或范围的另一个表），您可以使用IsOverlappedListObject 函数，我在下面写了一个用法示例：

Function IsOverlappedListObject(rng As Range, TargetName As String, Optional Reason As String = "") As Boolean
    Dim x As ListObject
    On Error Resume Next
    Set x = rng.Parent.ListObjects(TargetName)
    If Err.Number = 0 Then
        IsOverlappedListObject = True
        Reason = "The ListObject named """ & TargetName & """ already exists on the worksheet """ & rng.Parent.Name & """"
    End If
    On Error GoTo out
    Reason = Reason & IIf(Reason = "", "", vbLf) & "The range " & rng.Address & " overlaps (at least) with the ListObject(""" & rng.ListObject.Name & """) on the " & rng.Parent.Name & " worksheet"
    IsOverlappedListObject = True
out:
End Function

' usage example
Sub MakeTable()
    Dim rng As Range, TargetName As String, Reason As String
    Set rng = Range("A1").CurrentRegion
    TargetName = "Table1"
    
    If IsOverlappedListObject(rng, TargetName, Reason) Then
        MsgBox "Can't make ListObject - the reason is " & vbLf & Reason, vbCritical
    Else
        ActiveSheet.ListObjects.Add(xlSrcRange, _
                    rng, XlListObjectHasHeaders:=xlYes, _
                    TableStyleName:="TableStyleLight15").Name = TargetName
    End If
End Sub