[英]Loop through Counter to Increment variable value
我正在尝试创建 VBA 代码以根据当前日期命名工作表,但我正在努力解决一个问题,我需要一个计数器变量来命名工作表以便它们是唯一的,但我没有得到它.
我正在尝试 2 个代码:
Sub COPIAR_MODELO()
Application.ScreenUpdating = False
Dim i As Integer, x As Integer
Dim shtname As String
Dim WSDummy As Worksheet
Dim TxtError As String
Dim counter As Long
counter = 0
Name01:
For counter = 1 To 100 Step 0
TxtError = ""
counter = counter + 1
shtname = Format(Now(), "dd mm yyyy") & " - " & counter
On Error Resume Next
Set WSDummy = Sheets(shtname)
If Not (WSDummy Is Nothing) Then TxtError = "Name taken, additional sheet added!"
Next counter
If TxtError <> "" Then MsgBox "" & TxtError: GoTo Name01
Sheets("MODELO - NFS").Copy Before:=Sheets("MODELO - DEMAIS"): ActiveSheet.Name = shtname
Application.ScreenUpdating = True
End Sub
预期结果:
和
Sub COPIAR_MODELO()
Application.ScreenUpdating = False
Dim i As Integer, x As Integer
Dim shtname As String
Dim WSDummy As Worksheet
Dim TxtError As String
Dim counter As Long
TxtError = ""
shtname = Format(Now(), "dd mm yyyy")
On Error Resume Next
Set WSDummy = Sheets(shtname)
If Not (WSDummy Is Nothing) Then TxtError = "Name taken, additional sheet added!"
If TxtError <> "" Then MsgBox "" & TxtError: GoTo Name01
If TxtError = "" Then GoTo NameOK
Name01:
For counter = 1 To 100 Step 1
counter = counter + 1
shtname = Format(Now(), "dd mm yyyy") & " - " & counter
Next counter
NameOK:
Sheets("MODELO - NFS").Copy Before:=Sheets("MODELO - DEMAIS"): ActiveSheet.Name = shtname
Application.ScreenUpdating = True
End Sub
预期结果:
我将把这段代码分配给一个形状,以根据当前日期创建工作表。 我特别喜欢结果 2,但是任何有效的代码都会对我有所帮助,在此先感谢您的关注!!
Sub CopyTemplate()
Const PROC_TITLE As String = "Copy Template"
Const TEMPLATE_WORKSHEET_NAME As String = "MODELO - NFS"
Const BEFORE_WORKSHEET_NAME As String = "MODELO - DEMAIS"
Const DATE_FORMAT As String = "dd mm yyyy"
Const DATE_NUMBER_DELIMITER As String = " - "
Const FIRST_NUMBER As Long = 2
Const FIRST_WORKSHEET_HAS_NUMBER As Boolean = False
Const INPUT_BOX_PROMPT As String = "Input number of worksheets to create."
Const INPUT_BOX_DEFAULT As String = "1"
Dim WorksheetsCount As String: WorksheetsCount _
= InputBox(INPUT_BOX_PROMPT, PROC_TITLE, INPUT_BOX_DEFAULT)
If Len(WorksheetsCount) = 0 Then Exit Sub
Dim DateName As String: DateName = Format(Date, DATE_FORMAT)
Dim NewName As String: NewName = DateName
Dim NewNumber As Long: NewNumber = FIRST_NUMBER
If FIRST_WORKSHEET_HAS_NUMBER Then
NewName = NewName & DATE_NUMBER_DELIMITER & NewNumber
NewNumber = NewNumber + 1
End If
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim wsTemplate As Worksheet
Set wsTemplate = wb.Worksheets(TEMPLATE_WORKSHEET_NAME)
Dim wsBefore As Worksheet
Set wsBefore = wb.Worksheets(BEFORE_WORKSHEET_NAME)
Dim wsNew As Worksheet
Dim WorksheetNumber As Long
Application.ScreenUpdating = False
Do While WorksheetNumber < WorksheetsCount
On Error Resume Next
Set wsNew = wb.Worksheets(NewName)
On Error GoTo 0
If wsNew Is Nothing Then
wsTemplate.Copy Before:=wsBefore
wsBefore.Previous.Name = NewName
WorksheetNumber = WorksheetNumber + 1
Else
NewName = DateName & DATE_NUMBER_DELIMITER & NewNumber
NewNumber = NewNumber + 1
Set wsNew = Nothing
End If
Loop
Application.ScreenUpdating = True
MsgBox WorksheetsCount & " worksheet" & IIf(WorksheetsCount = 1, "", "s") _
& " created.", vbInformation, PROC_TITLE
End Sub
如果玩得太过...
Sub DeleteCreatedWorksheets()
Const PROC_TITLE As String = "Delete Created Worksheets"
Const BEFORE_WORKSHEET_NAME As String = "MODELO - DEMAIS"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim wsBefore As Worksheet
Set wsBefore = wb.Worksheets(BEFORE_WORKSHEET_NAME)
Dim wsIndex As Long: wsIndex = wsBefore.Index - 1
If wsIndex > 0 Then
Application.DisplayAlerts = False
Dim n As Long
For n = wsIndex To 1 Step -1
wb.Worksheets(n).Delete
Next n
Application.DisplayAlerts = True
End If
MsgBox wsIndex & " created worksheet" _
& IIf(wsIndex = 1, "", "s") & " deleted.", _
vbInformation, PROC_TITLE
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.