Microsoft Office Forum [ www.Office-Fragen.de ] >> READONLY <<

Microsoft Office 2003-2019 => Excel => Thema gestartet von: franzbrötchen am Juni 26, 2017, 18:51:35 Nachmittag

Titel: Office 2010: VBA - nur ausgewählte Tabellenblätter exportieren und Verlinkungen löschen
Beitrag von: franzbrötchen am Juni 26, 2017, 18:51:35 Nachmittag

Liebe Community,

ich hoffe ihr könnt mir bei nachfolgendem Problem weiterhelfen. Meine Google Suche und Selbstversuche haben mich leider nicht weitergebracht  :-\ Und zwar würde ich gerne folgendes VBA Makro basteln:

(1) aus dem geöffneten bestehenden Workbook möchte ich über ein Makro alle Tabellenblätter in eine neu zu erstellende Arbeitsmappe exportieren, die das Kürzel „export_“ vorne stehen haben. Also z.B. nur die Tabellenblätter export_Analyse1, export_Analyse2 sollen in die neue Arbeitsmappe exportiert werden (ohne die bestehende Arbeitsmappe zu verändern). 

(2) In der neuen Arbeitsmappe würde ich gerne alle Formeln der ursprünglichen Tabellen beibehalten, die Verknüpfungen zur alten Mappe sollen jedoch gelöscht werden (harte Werte, keine Verlinkung).

(3) Im Anschluss die neue Arbeitsmappe mit dem Namen „Export“ und dem aktuellen Datum im Ordner speichern, in dem die Ursprungsdatei (aus der die Tabellenblätter exportiert wurden) liegt.

Wäre wirklich genial, wenn mir einer von euch weiterhelfen kann. Ist wahrscheinlich für euch eine Sache von 1 Minute, aber ich hänge mich hier wirklich auf.  :D :D

Vielen Dank!!

Titel: Antw:Office 2010: VBA - nur ausgewählte Tabellenblätter exportieren und Verlinkungen löschen
Beitrag von: franzbrötchen am Juni 26, 2017, 20:12:18 Nachmittag

Ein Nachtrag: das Kürzel "export_" würde ich gerne in der neu erstellten Arbeitsmappe löschen. Das also die Tabellenblätter anstatt export_Analyse1, export_Analyse2 nur noch Analyse1 und Analyse2 heißen  :)

Titel: Antw:Office 2010: VBA - nur ausgewählte Tabellenblätter exportieren und Verlinkungen löschen
Beitrag von: franzbrötchen am Juni 26, 2017, 20:14:03 Nachmittag

Einen ersten Ansatz habe ich hier gefunden, kann ihn aber leider noch nicht so richtig auf meine Anforderungen übertragen
Quelle: http://www.vbaexpress.com/kb/getarticle.php?kb_id=359 (http://www.vbaexpress.com/kb/getarticle.php?kb_id=359)

Code: [Auswählen]

Option Explicit
 
Sub TwoSheetsAndYourOut()
    Dim NewName As String
    Dim nm As Name
    Dim ws As Worksheet
     
    If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
    "New sheets will be pasted as values, named ranges removed" _
    , vbYesNo, "NewCopy") = vbNo Then Exit Sub
     
    With Application
        .ScreenUpdating = False
         
         '       Copy specific sheets
         '       *SET THE SHEET NAMES TO COPY BELOW*
         '       Array("Sheet Name", "Another sheet name", "And Another"))
         '       Sheet names go inside quotes, seperated by commas
        On Error GoTo ErrCatcher
        Sheets(Array("Copy Me", "Copy Me2")).Copy
        On Error GoTo 0
         
         '       Paste sheets as values
         '       Remove External Links, Hperlinks and hard-code formulas
         '       Make sure A1 is selected on all sheets
        For Each ws In ActiveWorkbook.Worksheets
            ws.Cells.Copy
            ws.[A1].PasteSpecial Paste:=xlValues
            ws.Cells.Hyperlinks.Delete
            Application.CutCopyMode = False
            Cells(1, 1).Select
            ws.Activate
        Next ws
        Cells(1, 1).Select
         
         '       Remove named ranges
        For Each nm In ActiveWorkbook.Names
            nm.Delete
        Next nm
         
         '       Input box to name new file
        NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
         
         '       Save it with the NewName and in the same directory as original
        ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"
        ActiveWorkbook.Close SaveChanges:=False
         
        .ScreenUpdating = True
    End With
    Exit Sub
     
ErrCatcher:
    MsgBox "Specified sheets do not exist within this workbook"
End Sub