создание нового листа через vba через приватную книгу

Question

создание нового листа через vba через приватную книгу

Рейтинг: 0Ответов: 2Опубликовано: 28.07.2023

Не создается новый рабочий лист в excel через vba из приватной книги, только из личной. Может, кто знает, можно ли создать новый рабочий лист из частной настройки кнопки на ленте?

Моя часть кода:

Private Sub add_new_art(control As IRibbonControl)

    Dim selectedRange As Range
    Dim concatenatedString As String
    Dim newSheet As Worksheet
    Dim destinationCell As Range
    Dim sheetCounter As Long
    Dim sheetName As String

    ' Check if a range is selected
    If TypeName(Selection) <> "Range" Then
        MsgBox "Please select a range of cells before running this macro.", vbExclamation
        Exit Sub
    End If

    ' Get the selected range
    Set selectedRange = Selection

    ' Loop through each cell in the selected range and concatenate the cell values with commas
    For Each cell In selectedRange
        concatenatedString = concatenatedString & cell.Value & ","
    Next cell

    ' Remove the trailing comma from the concatenated string
    If Right(concatenatedString, 1) = "," Then
        concatenatedString = Left(concatenatedString, Len(concatenatedString) - 1)
    End If

    ' Create a new worksheet with a unique name to paste the concatenated result
    sheetCounter = 1
    Do
        sheetName = "ConcatenatedResult" & IIf(sheetCounter > 1, "_" & sheetCounter, "")
        On Error Resume Next
        Set newSheet = ThisWorkbook.Worksheets.Add
        newSheet.Name = sheetName
        On Error GoTo 0
        sheetCounter = sheetCounter + 1
    Loop While newSheet Is Nothing

    ' Set the destination cell in the new sheet (e.g., A1)
    Set destinationCell = newSheet.Range("A1") ' Replace with your desired destination cell

    ' Paste the concatenated result into the destination cell in the new sheet
    destinationCell.Value = concatenatedString
End Sub

Пробовал и другие варианты - просто создать новый рабочий лист, проблема именно в создании нового рабочего листа.

excel vba

Источник: Stack Overflow на русском

Answer 1

▲ 1Принят

Set newSheet = ThisWorkbook.Worksheets.Add

-->

Set newSheet = ActiveWorkbook.Worksheets.Add

Answer 2

▲ 1

TypeName(Selection) <> "Range". Эта проверка имеет смысл, если на листе есть объекты, которые могут быть выделены перед запуском макроса.

Переменная sheetCounter имела бы смысл при создании серии листов. Для составления имени листа в переменную можно записывать имя или индекс листа (например, брать из ячейки).

Если создается только один лист, цикл не нужен.

Если в книге уже есть лист с именем нового листа, On Error Resume Next обойдет ошибку при попытке переименования листа, но лист все равно будет создан (без переименования).

Вариант кода:

Private Sub add_new_art(control As IRibbonControl)
    Dim concatenatedString As String
'    Dim sheetName As String, destinationCell As String '
    Const sheetName As String = "ConcatenatedResult_5"
    Const destinationCell As String = "A1"
    
'    sheetName = "ConcatenatedResult_" & Cells(1, 1).Value '
'    destinationCell = Cells(1, 2).Value '
    
    If TypeName(Selection) <> "Range" Then
        MsgBox "Please select a range of cells before running this macro.", vbExclamation
        Exit Sub
    End If

    concatenatedString = f_MergeValue(Selection)
    Call addSheet(sheetName, destinationCell, concatenatedString)
    MsgBox "OK", 64, ""
End Sub

Private Function f_MergeValue(rng As Range) As String
    Dim cell As Range
    Dim sTemp As String
    
    For Each cell In rng
        If cell.Value <> "" Then sTemp = sTemp & "," & cell.Value
    Next cell
    
    f_MergeValue = Mid$(sTemp, 2)
End Function

Private Sub addSheet(sheetName As String, destinationCell As String, concatenatedString As String)
    If f_IsThereSheet(sheetName) Then MsgBox _
        "There is a sheet in the book with the name " & sheetName, 64, "": Exit Sub
     
    With ActiveWorkbook.Worksheets.Add
        .Name = sheetName
        .Range(destinationCell).Value = concatenatedString
    End With
End Sub

Private Function f_IsThereSheet(sheetName As String) As Boolean
    On Error Resume Next
    f_IsThereSheet = (ActiveWorkbook.Worksheets(sheetName).Name = sheetName)
End Function

создание нового листа через vba через приватную книгу

Ответы