VBA，根據列表創建一個新工作表並給它一個顏色

Question

我有一個代碼，可以根據一張名為“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

Answer 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

Answer 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