VBA Double Click event

Jeg kan godt lide at dine formulering lyder som om dette er et bestillingscenter for gratis ydelser :-)

Det har aldrig været ideen ban eksperten.dk, men er erfaringsudvekslings univers som der herligvis er mange der benytter og også tilbyder :-)

Hej jensen363

Placér denne VBA-kode i kodemodulet for Denne_projektmappe:

Public b_pvt As Boolean

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Dim var_pvt As Variant
    On Error Resume Next
        Set var_pvt = Target.PivotCell
        If Err.Number = 0 Then
            b_pvt = True
        End If
    On Error GoTo 0
End Sub

Private Sub Workbook_NewSheet(ByVal Sh As Object)
    If b_pvt Then
        Sh.Name = Sh.Cells(2, 2)
        With ThisWorkbook
            Sh.Move After:=.Sheets(.Sheets.Count)
        End With
        b_pvt = False
    End If
End Sub

Virker perfekt, - har du også en ide til en error handler hvis Sh.Name allered findes ?

Jeg tænker, at det letteste vil være at tilføje et dato- og tidstempel til arknavnet.

Sh.Name = Sh.Cells(2, 2) & "_" & Format(Now(),"YYMMDDHHMMSS").

Måske det endda er nok med tidsstemplet alene, dvs. "HHMMSS".

Der må ikke forekomme dubletter overhovedet, så jeg nøjes med en

On Error Resume Next :-)

Tak for hjælpen

Hvad kunne du tænke dig, der skulle ske i tilfælde af en dublet?
Det kunne eksempelvis være en besked om, at arket findes i forvejen, og at man kan vælge ja eller nej til at udskifte/opdatere arket.
Hvis du kun tilføjer "On Error Resume Next", vil arket stå tilbage med navnet, som Excel har tildelt automatisk.

Den løsning jeg har nu er reelt i orden, men dit forslag med en besked om, at arket findes i forvejen, og at man kan vælge ja eller nej til at udskifte/opdatere arket er perfrkt :-)

Makroen Workbook_NewSheet:

Private Sub Workbook_NewSheet(ByVal Sh As Object)
    Dim str_sh_name As String
    Dim sh_check As Worksheet
    If b_pvt Then
        str_sh_name = Sh.Cells(2, 2)
        On Error Resume Next
            Set sh_check = ThisWorkbook.Sheets(str_sh_name)
        On Error GoTo 0
        If Not sh_check Is Nothing Then
            With Application
                .DisplayAlerts = False
                .EnableEvents = False
                .ScreenUpdating = False
            End With
            If MsgBox("Arket " & str_sh_name & " findes allerede" & vbNewLine & vbNewLine & _
                  "Vil du erstatte det eksisterende ark med det nye ark?", _
                    vbYesNo + vbQuestion, "Erstat ark?") = vbYes Then
                    sh_check.Delete
                    Sh.Name = str_sh_name
            Else
                    Sh.Delete
                    Set Sh = Nothing
               
            End If
            With Application
                .DisplayAlerts = True
                .EnableEvents = True
                .ScreenUpdating = True
            End With
        Else
            Sh.Name = str_sh_name
        End If
        If Not Sh Is Nothing Then
            With ThisWorkbook
                Sh.Move After:=.Sheets(.Sheets.Count)
            End With
        End If
        b_pvt = False
    End If
End Sub