excel - 使用 Excel VBA 添加表格

Question

我想使用vba添加新工作表并在这些新工作表中添加表格。如下图所示，有两列和。我想为每个人创建新工作表，并根据它所属的工作表为每个人添加表格。此外，我可以添加and ，vba代码也应该为这些 添加工作表和表格。Main CategorySub CategoryMain CategorySub Categorynew entriesMain CategorySub Category

---

到目前为止，我可以添加新工作表，但无法添加表格，这就是我所拥有的：

    Sub CreateSheetsFromAList()
        Dim MyCell As Range, myRange As Range
        Dim MyCell1 As Range, myRange1 As Range
        Dim WSname As String

        Sheet1.Select
        Range("A2").Select
        Range(ActiveCell, ActiveCell.End(xlDown)).Select
        Set myRange = Selection
        Application.ScreenUpdating = False

         For Each MyCell In myRange
            If Len(MyCell.Text) > 0 Then
                'Check if sheet exists
                If Not SheetExists(MyCell.Value) Then

                    'run new reports code until before Else

                    Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
                    Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet

                    WSname = MyCell.Value 'stores newly created sheetname to a string variable

                    'filters consolidated sheet based on newly created sheetname
                    Sheet3.Select
                    Range("A:T").AutoFilter
                    Range("D1").Select
                    Range("D1").AutoFilter Field:=4, Criteria1:=WSname, Operator:=xlFilterValues

                    Range("A1:U1").Select
                    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
                    Range("A1:U" & lastRow).Select
                    Selection.Copy 'copies filtered data

                    'search and activate WSname
                    ChooseSheet WSname

                    Range("AH2").Select
                    ActiveCell.PasteSpecial xlPasteValues

                    Range("AJ:AJ").Select
                    Selection.NumberFormat = "hh:mm"
                    Range("B2").Select
                 End If
            End If

        Next MyCell

        End Sub

         Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
        Dim sht As Worksheet

         If wb Is Nothing Then Set wb = ThisWorkbook
         On Error Resume Next
         Set sht = wb.Sheets(shtName)
         On Error GoTo 0
         SheetExists = Not sht Is Nothing
         End Function

        Public Sub ChooseSheet(ByVal SheetName As String)
        Sheets(SheetName).Select
        End Sub

最终结果如下所示：

这是我没有任何代码的示例工作簿：https ://drive.google.com/file/d/16logfbrvoK3CVKb-j-g4167pvU_BoWYI/view?usp=sharing

标签： excelvba

Answer 1

这种方法应该让你开始。

注意：代码注释中有几个 TODO。

脚步：

1) 将您的数据库范围转换为名为 (TableDatabase) 的 Excel 结构化表格。

看这篇文章

2）在工作表“数据库”后面添加此代码

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Application.ScreenUpdating = False
    DatabaseManager.Change Target
    Application.ScreenUpdating = True

End Sub

3）添加一个模块并将其命名为“DatabaseManager”

4) 将此代码添加到 DatabaseManager 模块：

Option Explicit

Private Const DATABASE_TABLE_NAME As String = "TableDatabase"
Private Const DATABASE_MAINCAT_COLUMN_HEADER As String = "Main Category"
Private Const DATABASE_SUBCAT_COLUMN_HEADER As String = "Sub Category"

Private Const TABLE_OFFSET_ROWS As Long = 5
Private Const TABLE_COLUMN_LOCATION As Long = 1 ' 1 = A

Public Sub Change(ByVal Target As Range)

    Dim databaseTable As ListObject
    Dim tableRow As Long

    Set databaseTable = Range(DATABASE_TABLE_NAME).ListObject

    Select Case True
    Case Not Intersect(Target, databaseTable.ListColumns(DATABASE_MAINCAT_COLUMN_HEADER).DataBodyRange) Is Nothing
        ' TODO: Validate if adding, updating or deleting a main category

        ' Case: Add a main category sheet
        AddSheetByTitle Target.Value2, Target.Parent

        ' TODO: Case updating, deleting

    Case Not Intersect(Target, databaseTable.ListColumns(DATABASE_SUBCAT_COLUMN_HEADER).DataBodyRange) Is Nothing
        ' TODO: Validate if adding, updating  or deleting a sub category
        tableRow = Target.Row - databaseTable.HeaderRowRange.Row + 1

        ' Case: Add a subcategory table
        AddTableInSheetByName databaseTable.ListColumns(DATABASE_MAINCAT_COLUMN_HEADER).Range(tableRow), Target.Value2, Target.Parent

        ' TODO: Case updating, deleting

    Case Else

    End Select

End Sub

Public Function AddSheetByTitle(ByVal Title As String, Optional ByVal ReturnSheet As Worksheet) As Worksheet

    ' TODO: Validate if sheet name is valid

    If SheetExists(Title) = True Then Exit Function

    Dim newWorksheet As Worksheet
    Set newWorksheet = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))

    ' Rename the new sheet
    newWorksheet.Name = Title

    ' Return to a previous sheet
    If Not ReturnSheet Is Nothing Then ReturnSheet.Activate

    Set AddSheetByTitle = newWorksheet

End Function

Public Function AddTableInSheetByName(ByVal TargetSheetName As String, ByVal TableName As String, Optional ByVal ReturnSheet As Worksheet) As ListObject

    Dim targetSheet As Worksheet
    Dim targetTable As ListObject
    Dim lastRow As Long

    If SheetExists(TargetSheetName) = False Then
        Set targetSheet = AddSheetByTitle(TargetSheetName)
    End If

    If TableExists(TableName) = True Then Exit Function

    Set targetSheet = ThisWorkbook.Worksheets(TargetSheetName)

    lastRow = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Row

    Set targetTable = targetSheet.ListObjects.Add(SourceType:=xlSrcRange, Source:=targetSheet.Cells(lastRow, TABLE_COLUMN_LOCATION).Offset(TABLE_OFFSET_ROWS))

    targetTable.Name = TableName

    ' Set table headers and content
    targetTable.HeaderRowRange.Cells(1).Value2 = TableName

    ' Return to a previous sheet
    If Not ReturnSheet Is Nothing Then ReturnSheet.Activate


End Function

Private Function SheetExists(ByVal SheetName As String) As Boolean
    Dim evalSheet As Worksheet

    On Error Resume Next
    Set evalSheet = ThisWorkbook.Sheets(SheetName)
    On Error GoTo 0

    SheetExists = (Not evalSheet Is Nothing)
End Function

Private Function TableExists(ByVal TableName As String) As Boolean
    Dim evalTable As ListObject
    Dim evalName As String
    ' TODO: check if TableName is valid (search for invalid chars)
    evalName = Replace(TableName, " ", "_")
    On Error Resume Next
    TableExists = (Range(evalName).ListObject.Name = TableName)
    On Error GoTo 0
End Function

注意：您的最终结果属于特定类型的表格。我的代码（如您最初询问的那样）向工作表添加了一个新表。另一种方法是复制（复制）源表并重命名它。

希望这可以帮助。如果有，记得标记答案。