[英]How do I modify this vba to copy column width and conditional formatting to an active sheet?
I am new to VBA.我是 VBA 的新用户。
Thank you for your time.感谢您的时间。 I have been Googling for 2 days and always get an error.
我已经用谷歌搜索了 2 天,但总是出错。
I have two sheets我有两张床单
I have 2 issues I am trying to solve:我有 2 个问题要解决:
How do I copy the format on an active sheet including conditional formatting and column width.如何复制活动工作表上的格式,包括条件格式和列宽。 PasteSpecial already copies all the colour design but not the column width/conditional formatting
PasteSpecial 已经复制了所有颜色设计,但没有复制列宽/条件格式
When I run the code it creates a new sheet called Project Name,not sure where that is coming from.当我运行代码时,它会创建一个名为项目名称的新工作表,但不确定它来自哪里。
This is the code I am using:这是我正在使用的代码:
Sub Copy()
Sheets("Template").Range("A1:O100").Copy
ActiveSheet.PasteSpecial
End Sub
<<<<<<<<<<<<<<<<<<<<<< <<<<<<<<<<<<<<<<<<<<<<
I want to generate a project name, make sure it does not exist(no duplicate), open a new sheet and copy the template from "template".我想生成一个项目名称,确保它不存在(没有重复),打开一个新工作表并从“模板”复制模板。
The full codes is:完整的代码是:
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
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.