VBA，根据列表创建一个新工作表并给它一个颜色答案

【问题标题】：VBA, create a new sheet based on a list and give it a colorVBA，根据列表创建一个新工作表并给它一个颜色
【发布时间】：2023-04-11 12:04:01
【问题描述】：

我有一个代码，可以根据一张名为“Röd”的表格中的列表创建一个新表格。我尝试为新创建的工作表提供颜色，但没有使任何工作？如何使用我的代码为新创建的工作表着色？

Sub Röd()

    Dim MyCell As Range, MyRange As Range
    Dim ws As Worksheets
    

    'This Macro will create separate tabs based on a list in Distribution Tab A2 down

    Set MyRange = Sheets("Röd").Range("A3")
    Set MyRange = Range(MyRange, MyRange.End(xlDown))
    

    Application.DisplayAlerts = False

    For Each MyCell In MyRange
         If SheetCheck(MyCell) = False And MyCell <> "" Then
            Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
            Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
            .Color = RGB(255, 0, 0)
            End If
    
    
    Next
    
    Application.DisplayAlerts = True
    
End Sub

【问题讨论】：

标签： excel vba colors tabs

【解决方案1】：

这是你正在尝试的吗？

我已经对代码进行了注释，因此您理解它应该没有问题。如果您仍有疑问，请直接提问。

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim lRow As Long
    Dim i As Long
    
    '~~> Set this to the relevant worksheet
    Set ws = Sheets("Röd")
    
    With ws
        '~~> Find last row in Column A
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        
        '~~> Loop through the range
        For i = 3 To lRow
            '~~> Check if cell is not empty
            If Len(Trim(.Range("A" & i).Value2)) <> 0 Then
                '~~> Check if the sheet already exists
                If SheetCheck(.Range("A" & i)) = False Then
                    With ThisWorkbook
                        '~~> Add the sheet
                        .Sheets.Add After:=.Sheets(.Sheets.Count)
                        '~~> Color the tab
                        .Sheets(.Sheets.Count).Tab.Color = RGB(255, 0, 0)
                        '~~> Name the tab
                        .Sheets(.Sheets.Count).Name = ws.Range("A" & i).Value2
                    End With
                End If
            End If
        Next i
    End With
End Sub

Function SheetCheck(MyCell As Range) As Boolean
    Dim wsht As Worksheet
    
    For Each wsht In ThisWorkbook.Worksheets
        If wsht.Name = MyCell.Value2 Then
            SheetCheck = True
            Exit For
        End If
    Next
End Function

【讨论】：

“如果 SheetCheck(.Range("A" & i).Value2) = False Then”出现错误。它说需要对象
Function SheetCheck(MyCell As Range) As Boolean Dim ws As Worksheet SheetCheck = False For Each ws In ThisWorkbook.Worksheets If ws.Name = MyCell Then SheetCheck = True End If Next End Function
我看到了您如何编写颜色代码，并在我的代码中使用了它。现在可以了，看我的回答
我的代码没有问题。这就是您使用代码SheetCheck 的方式。您将参数声明为范围MyCell As Range。请参阅我更新的帖子。现在它将起作用。您可能需要刷新页面才能看到它。您所要做的就是在我的代码中将If SheetCheck(.Range("A" & i).Value2) = False Then 更改为If SheetCheck(.Range("A" & i)) = False Then
是的，现在您的代码也可以正常工作了！谢谢您的帮助！如果单元格中的名称长于 30 个字符以使用前 30 个字符，您知道如何编写代码吗？即使单元格名称超过 30 个字符，也可以跳过其余部分以命名新工作表？

【解决方案2】：

现在可以了。之前写的不对。

Sub Röd()
    Dim MyCell As Range, MyRange As Range
    Dim ws As Worksheets
    
    'This Macro will create separate tabs based on a list in Distribution Tab A2 down

    Set MyRange = Sheets("Röd").Range("A3")
    Set MyRange = Range(MyRange, MyRange.End(xlDown))

    Application.DisplayAlerts = False

    For Each MyCell In MyRange
        If SheetCheck(MyCell) = False And MyCell <> "" Then
            Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
            Sheets(Sheets.Count).Tab.Color = RGB(255, 0, 0) 'give the new tab color red
            Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
        End If
    Next
    
    Application.DisplayAlerts = True
End Sub

【讨论】：