将范围转换为表格

Question

我有一个 Excel 电子表格，其中包含“分析”和“数据库”选项卡。我想在 Analysis 中创建一个按钮，单击该按钮会将数据库选项卡转换为表。数据库不是静态的，不同的用户总是在添加数据。

我有下面的代码，但它在“.parent ...”代码行失败。

Sub Convert_Table()
 
 With ThisWorkbook.Sheets("Database").Range("a1")

    .Parent.ListObjects.Add(xlSrcRange, ThisWorkbook.Sheets("Database").Range(.End(xlDown), .End(xlToRight)), , xlYes).Name = "Table1"

  End With

End Sub

Answer 1

ThisWorkbook.Sheets("Database").Range("a1").Parent

就是

Sheets("Database")

。简化您的代码。

我会做稍微不同的事情。

我将找到最后一行和最后一列来确定我的范围，然后创建表格。如果

xlDown

和

xlToRight

之间有空白单元格，则不可靠。

这是您正在尝试的吗（未经测试）？我已经对代码进行了评论，但如果您仍然无法理解它，只需在下面发表评论即可。

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim rng As Range
    Dim tbl As ListObject

    '~~> This is your worksheet
    Set ws = ThisWorkbook.Sheets("Database")
    
    With ws
        '~~> Unlist the previously created table
        For Each tbl In .ListObjects
            tbl.Unlist
        Next tbl

        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            '~~> Find last row
            lastRow = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
            
            '~~> Find last column
            lastCol = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByColumns, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Column
            
            '~~> Set your rnage
            Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
            
            '~~> Create the table
            .ListObjects.Add(xlSrcRange, rng, , xlYes).Name = "Table1"
        End If
    End With
End Sub

Answer 2

子发送批量电子邮件() Dim ws1 作为工作表，ws2 作为工作表，ws3 作为工作表 昏暗的approverDict作为对象 昏暗的批准者名称为字符串，批准者电子邮件为字符串 Dim emailSubject 作为字符串，emailBody 作为字符串，ccEmails 作为字符串 调暗 OutlookApp 作为对象，outlookMail 作为对象 Dim lastRow1 As Long、lastRow2 As Long、i As Long、j As Long 暗淡数据范围作为范围，单元格作为范围 Dim emailTable 作为字符串，uniqueApprovers 作为对象 调暗 sendBtn 作为范围

' Set worksheets
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Set ws3 = ThisWorkbook.Sheets("Sheet3")
Set approverDict = CreateObject("Scripting.Dictionary")
Set uniqueApprovers = CreateObject("Scripting.Dictionary")

' Get email details from Sheet3
emailSubject = ws3.Range("B2").Value
emailBody = ws3.Range("C2").Value
ccEmails = ws3.Range("D2").Value

' Get approver emails from Sheet2
lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
For i = 1 To lastRow2
    approverName = ws2.Cells(i, 1).Value
    approverEmail = ws2.Cells(i, 2).Value
    approverDict(approverName) = approverEmail
Next i

' Get data from Sheet1
lastRow1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
Set dataRange = ws1.Range("A2:I" & lastRow1)

' Check for empty Item No cells in Sheet1
For Each cell In dataRange.Columns(1).Cells ' Column A
    If cell.Value = "" Then
        MsgBox "Item No column in row " & cell.Row & " is empty. Stopping operation."
        Exit Sub
    End If
Next cell

' Check for empty Time cells in Sheet1
For Each cell In dataRange.Columns(7).Cells ' Column G
    If cell.Value = "" Then
        MsgBox "Timestamp column in row " & cell.Row & " is empty. Stopping operation."
        Exit Sub
    End If
Next cell

' Collect unique approvers
For Each cell In dataRange.Columns(9).Cells ' Column I
    If Not uniqueApprovers.exists(cell.Value) Then
        uniqueApprovers.Add cell.Value, Nothing
    End If
Next cell

' Initialize Outlook application
On Error Resume Next
Set outlookApp = GetObject(class:="Outlook.Application")
If outlookApp Is Nothing Then
    Set outlookApp = CreateObject(class:="Outlook.Application")
End If
On Error GoTo 0

' Send emails to each unique approver
For Each approverName In uniqueApprovers.Keys
    If approverDict.exists(approverName) Then
        approverEmail = approverDict(approverName)
        emailTable = "<table border='1'><tr><th>Item No</th><th>Name</th><th>Service</th><th>Service Details</th><th>Division</th><th>Region</th></tr>"

        ' Collect data for the current approver
        For i = 2 To lastRow1
            If ws1.Cells(i, 9).Value = approverName Then ' Column I
                emailTable = emailTable & "<tr>"
                For j = 1 To 6
                    emailTable = emailTable & "<td>" & ws1.Cells(i, j).Value & "</td>"
                Next j
                emailTable = emailTable & "</tr>"
            End If
        Next i

        emailTable = emailTable & "</table>"

        ' Create and send email
        Set outlookMail = outlookApp.CreateItem(0)
        With outlookMail
            .To = approverEmail
            .CC = ccEmails
            .Subject = emailSubject
            .HTMLBody = emailBody & "<br>" & emailTable
            .Send
        End With

        ' Add timestamp to each item for the current approver
        For i = 2 To lastRow1
            If ws1.Cells(i, 9).Value = approverName Then
                ws1.Cells(i, 7).Value = Now ' Set timestamp in Column G
            End If
        Next i
    Else
        MsgBox "Email address for approver " & approverName & " not found."
    End If
Next approverName

MsgBox "Emails sent successfully!"

结束子