如何修改此 vba 以將列寬和條件格式復制到活動工作表？

Question

我是 VBA 的新用戶。

感謝您的時間。 我已經用谷歌搜索了 2 天，但總是出錯。

我有兩張床單

1. 項目（我將在其中存儲項目名稱）和
2. 模板（將使用“模板”表創建新項目）

我有 2 個問題要解決：

1. 如何復制活動工作表上的格式，包括條件格式和列寬。 PasteSpecial 已經復制了所有顏色設計，但沒有復制列寬/條件格式

2. 當我運行代碼時，它會創建一個名為項目名稱的新工作表，但不確定它來自哪里。

這是我正在使用的代碼：

Sub Copy()
Sheets("Template").Range("A1:O100").Copy
ActiveSheet.PasteSpecial
End Sub
 

<<<<<<<<<<<<<<<<<<<<<<

我想生成一個項目名稱，確保它不存在（沒有重復），打開一個新工作表並從“模板”復制模板。

完整的代碼是：

RunAll()
CreateProjectName
CreateNewTab
CopyPaste
End Sub

Dim AddData As Range
Dim AddName As String
Set AddData = Cells(Rows.Count, 4).End(xlUp).Offset(1, 0)
AddName = InputBox("Enter Project Name do not input manually", "Project Monitor")
If AddName = "" Then Exit Sub
AddData.Value = AddName
AddData.Offset(0, 1).Value = Now
End Sub


Function SheetCheck(sheet_name As String) As Boolean
Dim ws As Worksheet
SheetCheck = False
For Each ws In ThisWorkbook.Worksheets
    If ws.Name = sheet_name Then
            SheetCheck = True
          End If
Next
End Function


Sub CreateNewTab()
Dim sheets_count As Integer
Dim sheet_name As String
Dim i As Integer
sheet_count = Range("D3:D1000").Rows.Count
For i = 1 To sheet_count
    sheet_name = Sheets("Projects").Range("D3:D1000").Cells(i, 1).Value
        If SheetCheck(sheet_name) = False And sheet_name <> "" Then
    Worksheets.Add(After:=Sheets("Projects")).Name = sheet_name
    End If

Next i
End Sub


Sub CopyPaste()
Sheets("Template").Range("A1:o100").Copy
  ActiveSheet.PasteSpecial
End Sub

Answer 1

Option Explicit

Sub AddProject()
   
    Dim ws As Worksheet, NewName As String
    NewName = InputBox("Enter Project Name do not input manually", "Project Monitor")
   
    ' checks
    If NewName = "" Then
        MsgBox "No name entered", vbCritical
        Exit Sub
    Else
        ' check sheet not existing
        For Each ws In ThisWorkbook.Sheets
            If UCase(ws.Name) = UCase(NewName) Then
                MsgBox "Existing Sheet '" & ws.Name & "'", vbCritical, "Sheet " & ws.Index
                Exit Sub
            End If
        Next
    End If
   
    ' check not existing in list
    Dim wb As Workbook, n As Long, lastrow As Long, v
   
    Set wb = ThisWorkbook
    With wb.Sheets("Projects")
        lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row
        v = Application.Match(NewName, .Range("D1:D" & lastrow), 0)
        ' not existing add to list
        If IsError(v) Then
            .Cells(lastrow + 1, "D") = NewName
            .Cells(lastrow + 1, "E") = Now
        Else
            MsgBox "Existing Name '" & NewName & "'", vbCritical, "Row " & v
            Exit Sub
        End If
    End With
   
    ' create sheet
    n = wb.Sheets.Count
    wb.Sheets("Template").Copy after:=wb.Sheets(n)
    wb.Sheets(n + 1).Name = NewName
    MsgBox NewName & " added as Sheet " & n + 1, vbInformation
   
End Sub