Werkblad kopie maken VBA met msgBox

[safe]

Hallo,

Ik zit al een tijdje te stoeien met het opzoeken van een macro waarbij ik de actieve werkblad kan opslaan onder een nieuwe werkbladnaam dat is te vinden in cel E6.
Dit werkblad moet als tablad/werkblad opgeslagen worden binnen het zelfde excel document.
Daarbij wil ik graag een msgBox indien er al een werkblad onder dezelfde naam bestaat. Deze msgBox moet de optie geven om de taak te annuleren ( cancel/no ) of om de bestaande werkblad te overschrijven.

Kan iemand mij daarmee helpen ?

Alvast bedankt !

M.vr.gr.
Safe

 

[Warme bakkertje]

Bijv.

Sub tst()
    If Evaluate("isref(" & ActiveSheet.Range("C6") & "!A1)") Then
        If MsgBox("Blad bestaat reeds, wil je dit overszchrijven ?", vbYesNo) = vbYes Then
            MsgBox "Blad gekopieërd" 'hier komt dan kopieërcode
        Else
        End If
    End If
End Sub

 

[safe]

Ik krijg bij voorbaat al een melding dat het werkblad al bestaat.
Ik heb geprobeerd deze code werkend te krijgen door mijn " Kopieercode " erboven te plaatsen maar wederom geen gewenst resultaat.

Ik gebruik onderstaande code dat ik van het internet heb afgeplukt.

Sheets("Acc.lijst").Select
    Sheets("Acc.lijst").Copy After:=Sheets(4)
    Range("E6") = Range("E6")
    ActiveSheet.Name = Range("E6")

Wat gaat hier fout?

M.vr.gr.
Safe

 

[HSV]

Test het eens.

Sub hsv()
Dim naam As String, x
With Sheets("Blad1")
naam = .Range("E6").Value
If Not IsError(Evaluate(.Range("E6").Value & "!A1")) Then
 If MsgBox("Blad bestaat al" & vbLf & "Overschrijven?", vbDefaultButton2 + vbYesNo, "Let op") = vbYes Then
  x = Array(naam, "Blad1")
    Sheets(x).FillAcrossSheets _
        Worksheets("Blad1").Cells, -4104
      Exit Sub
    Else: Exit Sub
    End If
   End If
   Sheets.Add.Name = naam
     .Cells.Copy Sheets(naam).Cells
 End With
End Sub

 

[safe]

Werkt bijna...

Vergeten erbij te vermelden dat ik in mijn werkblad werk met formules.
Zo werkt 1 formule niet meer. Dat is de formule die hieronder staat vermeld.

Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("C21:C645")) Is Nothing Then
 If Target <> "" Then Target.Offset(1, 0).RowHeight = 85
 If Target = "" And Target.Offset(1, 0) = "" Then Target.Offset(1, 0).RowHeight = 0
 If Target = "" And Target.Offset(-1, 0) = "" Then Target.RowHeight = 0
 End If
 End Sub

Ik gebruik deze om automatisch een regel in Excel " toe te voegen " zodra ik een regel daarboven heb ingevuld. ( zie screenshots 1 & 2 )
In de 3e screenshot zie je het resultaat van het gekopieerde blad welke ik dmv de macro liet kopiëren. Alle rijen zijn dan uitgevouwen en staan dan niet meer op rijhoogte 0 zoals bij screenshot 2.


Valt het nog te voorkomen dat ook op het gekopieerde tabblad de " niet ingevulde " rijen op rijhoogte 0 blijven staan?
Ik werk met de Nederlandse versie van Office 2010.

Alvast bedankt !
M.vr.gr.
Safe

 

[HSV]

Aan plaatjes hebben we niets.
Je kan ook een voorbeeldbestand bijvoegen.
Geef even in het bestand aan om welke cellen of rij het gaat met wat je wil en wilt bereiken.

Voor mij wordt het niet eerder dan morgenavond om ernaar te kijken.

 

[safe]

HSV,

Hierbij het voorbeeldbestandje waarin kort staat toegelicht wat ik graag wil bereiken.
Kort gezegd dient de macro welke aan het originele werkblad staat gekoppeld mee gekopieerd te worden met het kopie werkblad.

Zie voorbeeld..

Bekijk bijlage Voorbeeld.xlsm

 

[HSV]

Safe,

Sub hsv()
Dim naam As String, x, rw As Long
With [COLOR=#FF0000]ActiveSheet[/COLOR]
naam = .Range("E6").Value
If Not IsError(Evaluate(.Range("E6").Value & "!A1")) Then
 If MsgBox("Blad bestaat al:" & vbLf & "Overschrijven?", vbDefaultButton2 + vbYesNo, "Let op") = vbYes Then
  x = Array(naam, "Blad1")
    Sheets(x).FillAcrossSheets _
        Worksheets("Blad1").Cells, -4104
      Exit Sub
    Else: Exit Sub
    End If
   End If
   Sheets.Add.Name = naam
       .Cells.Copy Sheets(naam).Cells
     [COLOR=#FF0000]Sheets(naam).Shapes(1).OnAction = "hsv"
     For rw = 21 To 645
        If .Rows(rw).RowHeight = 0 Then Sheets(naam).Rows(rw).RowHeight = 0
     Next rw[/COLOR]
  End With
End Sub

 

[safe]

Super, dat werkt zoals ik het in gedachten had !!
HSV enorm bedankt voor je inspanningen !!! :thumb:

Gr,
Safe