我正在創建一個作業表保存功能，理想情況下，我希望它從兩個單元格中的名稱中獲取資訊，然后將其添加到作業表名稱中，但如果遇到副本，請在末尾添加一個數字。我在互聯網上尋找了一些答案，這在一定程度上幫助我發展了自己的
這是我到目前為止所得到的，
所以按鈕
Sub Test()
'Copy New Sheet
Sheets("Blank MAR").Copy Before:=Sheets(1)
Sheets("Blank MAR (2)").Name = Funct.GetUniqueName
End Sub
然后函式
Function Get_in()
Get_in = Left(Range("B1"), 1) & Left(Range("C1"), 1) " " Range("B2")
End Function
Function GetUniqueName(strProject As String) As String
' If this is the first time it's being used, just return it without a number...
If Not SheetNameExists(Funct.Get_in) Then
GetUniqueName = Funct.Get_in
Exit Function
End If
' Otherwise, suffix the sheet name with a number, starting at 2...
Dim i As Long, strName As String
i = 1
Do
i = i 1
strName = "Funct.Get_in(" & i & ")"
Loop While SheetNameExists(strName)
GetUniqueName = strName
End Function
Function SheetNameExists(strName As String) As Boolean
Dim sh As Worksheet
For Each sh In Worksheets
If StrComp(sh.Name, strName, vbTextCompare) = 0 Then
SheetNameExists = True
Exit Function
End If
Next
End Function
希望有人可以幫助 非常感謝
uj5u.com熱心網友回復：
如果作業表存在則添加增量
Sub Test()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("Blank MAR")
Dim BaseName As String: BaseName = GetBaseName(sws)
sws.Copy Before:=wb.Sheets(1)
Dim dws As Worksheet: Set dws = wb.Sheets(1)
Dim UniqueName As String: UniqueName = GetUniqueSheetName(wb, BaseName)
dws.Name = UniqueName
End Sub
幫助
Function GetBaseName( _
ByVal ws As Worksheet) _
As String
GetBaseName = Left(ws.Range("B1"), 1) _
& Left(ws.Range("C1"), 1) & " " & ws.Range("B2")
End Function
Function GetUniqueSheetName( _
ByVal wb As Workbook, _
ByVal BaseName As String) _
As String
Dim UniqueName As String: UniqueName = BaseName
Dim n As Long: n = 1
Do While IsSheetNameTaken(wb, UniqueName)
n = n 1
UniqueName = BaseName & " (" & n & ")"
Loop
GetUniqueSheetName = UniqueName
End Function
Function IsSheetNameTaken( _
ByVal wb As Workbook, _
ByVal SheetName As String) _
As Boolean
Dim sh As Object
On Error Resume Next
Set sh = wb.Sheets(SheetName)
On Error GoTo 0
IsSheetNameTaken = Not sh Is Nothing
End Function
短版
Sub TestShorter()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("Blank MAR")
sws.Copy Before:=wb.Sheets(1)
wb.Sheets(1).Name = GetUniqueSheetName(wb, GetBaseName(sws))
End Sub
Sub TestShortest()
Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets("Blank MAR")
sws.Copy Before:=sws.Parent.Sheets(1)
sws.Parent.Sheets(1).Name = GetUniqueSheetName(sws.Parent, GetBaseName(sws))
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/526180.html
標籤：擅长vba