Workbook splitsen, 1 unieke sheet en 1 dezelfde meenemen

[covux]

Hey,


Ik wil graag een 'workbook' splitsen hiervoor moet telkens 1 unieke sheet en 1 sheet met brongegevens mee gekopieerd worden.

Nu heb ik de volgende code

Sub Splitbook()


Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
    xWs.Copy
    
    Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

ALs ik de code zijn werk laat doen krijg ik telkens nieuwe bestanden met 1 sheet.
Ik heb echter nu een tweede sheet nodig zodat ik de verwijzingen kan blijven gebruiken voor sheet1.
Deze tweede sheet moet dus altijd mee gekopieerd worden.


Wat en hoe moet ik het zo aanpassen dat er wel telkens een unieke sheet wordt meegenomen+ de sheet met alle brongegevens.
Ik hoop namelijk dat op die manier de verwijzingen meegenomen worden die ik heb gemaakt.

In het voorbeeld bestand zitten geen verwijzingen is.
Is dit ook nog iets waar ik rekening mee moet houden of mag ik er van uitgaan dat alle verwijzingen automatisch meegenomen worden naar het nieuwe bestand.

Groet,
Covux


Bekijk bijlage SplitsenHelpmij.xlsx

 

[VenA]

Bv

Sub VenA()
For Each sh In Sheets
  If sh.Name <> "Blad1" Then
    Sheets(Array("Blad1", sh.Name)).Copy
    With ActiveWorkbook
      .SaveAs ThisWorkbook.Path & "\" & sh.Name & ".xlsx", 51
      .Close 0
    End With
  End If
Next sh
End Sub

 

[covux]

Bv

Sub VenA()
For Each sh In Sheets
  If sh.Name <> "Blad1" Then
    Sheets(Array("Blad1", sh.Name)).Copy With ActiveWorkbook
      .SaveAs ThisWorkbook.Path & "\" & sh.Name & ".xlsx", 51
      .Close 0
    End With
  End If
Next sh
End Sub

Krijg een foutmelding.

fout 1004 tijdens uitvoering
Methode Copy van Klasse Sheets is mislukt.

Heb ook "Blad1" gewisseld voor "Sheet1" ook dit werkt helaas niet.

Heb wel de NL versie van EXCEL.

 

[VenA]

Doet het hier gewoon.

 

[covux]

Doet het hier gewoon.

even bestand opnieuw geopend en nu doet die het inderdaad.

Krijg nu alleen nadat er een nieuwe map is aangemaakt de melding of ik ook de macro's wil mee nemen.

Heb in de Code xlsx als gewijzigd in xlsm, dit lost alleen het probleem niet op.

Is er een functie waarmee hij deze melding automatische negeert?


Update

Probleem opgelost.

door "Application.DisplayAlerts = False" toe te voegen krijg ik niet meer de melding.

Zo werkt de Code voor mij het best

Sub VenA()

Application.DisplayAlerts = False 
For Each sh In Sheets
  If sh.Name <> "Blad1" Then
    Sheets(Array("Blad1", sh.Name)).Copy 
    With ActiveWorkbook
      .SaveAs ThisWorkbook.Path & "\" & sh.Name & ".xlsx", 51
      .Close 0
    End With
  End If
Next sh
End Sub

VenA bedankt voor je hulp!

 

[VenA]

Heb je de code wel in een gewone module ipv in een bladmodule staan? Fouten/melding onderdrukken mag natuurlijk wel maar dan moet je wel de oorzaak en het gevolg weten

 

[covux]

Ik heb de code in een gewone module gedaan( via 'invoegen' en dan 'module' en dan krijg ik dus die melding.

de achterliggende oorzaak en gevolg weet ik niet. maar met het negeren van de foutmelding lukt het wel.

en als ik dan de bestanden nakijk heb ik he wel zoals ik het wil hebben.

EDIT

de code werkt ook niet in een bladmodule en workbook.

dit is trouwens de melding die ik krijg.

ALs ik de foutmelding negeer dan werkt alles dus wel gewoon en naar behoren.

 

[HSV]

Dat is een melding bij het opslaan van je werkboek met macro's met een .xlsx extensie.
Gebruik opslaan.als → .xlsb of .xlsm.

Als je het als macro bestand wilt opslaan.

.SaveAs ThisWorkbook.Path & "\" & sh.Name & [COLOR="#0000FF"]".xlsm", 52[/COLOR]

En zet "Displayalerts" aan het einde van de code weer op 'True'.

Er wordt sowieso geen code mee genomen naar je nieuw bestand als je het in een module zet.

 

[covux]

Opslaan als Macro is niet per se nodig.

Ik had inderdaad al eens de extensie aangepast in de macro naar xlsm.
Echter heb ik niet het getal er achter gewijzigd.

Als ik nu xlsm, 52 gebruik dan doet alles het inderdaad ook prima.
Domme fout dat ik daar nooit naar gekeken heb. 
Weer wat geleerd! Bedankt voor je antwoord!

 

[HSV]

Zie mijn laatste regel in mijn vorig schrijven.
Menu Invoegen in Vb-editor → Module, daar de code plaatsen.

 

[covux]

ja sorry, was iets te snel