VBA neue Arbeitsmappe erzeugen

Hallo,
habe folgendes Problem
Meine Arbeitsmappe "Ursprung" hat 123 Register
In Tabelle1 stehen Daten, welche für Tabellen 3 bis 123 notwendig sind.
In Tabelle2 Spalte B Zeile 6 bis 126 stehen die 120 Namen der Tabellen 3 bis 123.
Die Zellen der Tabellen 3 bis 123 werden über SVERWEIS individuell mit Daten aus Tabelle1 versorgt.
Ich benötige ein Makro, welches x neue Arbeitsmappen erzeugt.
Z.B. heißt in "Ursprung" die 3. Tabelle Messung1.
Die neue Arbeitsmappe soll Messung1.XLS heißen.
In der neuen Arbeitsmappe Messung1.XLS soll dann wiederum
die Tabelle "Messung1" aus "Ursprung" stehen.
Aber nur mit den Ergebnissen aus den SVERWEISEN,
keine Bezüge nach "Ursprung", Schriftfuß etc. soll aber bleiben.
Weil nicht immer alle Arbeitsmappen erzeugt werden sollen,
muss in "Ursprung" "Tabelle2" in Spalte C Zeile 6 bis 126
mit x die zu erzeugende Arbeitsmappe angewählt werden.
Die neuen Arbeitsmappen sollen im gleichen Verzeichnis von "Ursprung" abgelegt werden.
Falls eine neu zu erzeugende Arbeitsmappe bereits existiert,
soll eine MSG-Box zum überschreiben Ja / Nein kommen.
Habe versucht aus einzelnen Beiträge mir etwas zusammenzubauen, bin aber gescheitert.
Vielen Dank für eure Hilfe
mit freundlichen Grüßen
Uwe

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub WorkbookExport() Dim i As Integer Dim wbkOpen As Workbook Dim strFileName As String With ThisWorkbook For i = 6 To 126 If .Worksheets(2).Cells(i, 3) = "x" Then 'Dateiname von Tabellenblatt strFileName = .Worksheets(i - 3).Name & ".xls" 'Dateien mit dem Namen schließen For Each wbkOpen In Workbooks If wbkOpen.Name = strFileName Then wbkOpen.Close SaveChanges:=False Exit For End If Next 'Tabelle kopieren .Worksheets(i - 3).Copy 'Formels durch Werte ersetzen With ActiveSheet.UsedRange .Cells = .Cells.Value End With 'neue Arbeitsmappe speichern On Error Resume Next ActiveWorkbook.SaveAs ThisWorkbook.Path & "/" & strFileName On Error GoTo 0 'falls neue Datei geschlossen werden soll 'ActiveWorkbook.Close End If Next i End With End Sub

Hallo Uwe,
bitte wechsle in den VBA-Editor (Alt+F11) und exportiere das Modul mit dem benötigten Makro1. Anschließend passt du in folgendem Makro noch den Dateipfad zu dem exportierten Modul an (Zeile strImportModul = "c:\..."):

Sub WorkbookExport()
Dim i As Integer
Dim wbkOpen As Workbook
Dim strFileName As String
Dim strImportModul As String
'Dateipfad für Makromodul anpassen
strImportModul = "C:\Programme\Microsoft Office\OFFICE11\Modul1.bas"
With ThisWorkbook
For i = 6 To 126
If .Worksheets(2).Cells(i, 3) = "x" Then
'Dateiname von Tabellenblatt
strFileName = .Worksheets(i - 3).Name & ".xls"
'Dateien mit dem Namen schließen
For Each wbkOpen In Workbooks
If wbkOpen.Name = strFileName Then
wbkOpen.Close SaveChanges:=False
Exit For
End If
Next
'Tabelle kopieren
.Worksheets(i - 3).Copy
ActiveWorkbook.VBProject.VBComponents.Import (strImportModul)
'Formeln durch Werte ersetzen
With ActiveSheet.UsedRange
.Cells = .Cells.Value
End With
'neue Arbeitsmappe speichern
On Error Resume Next
ActiveWorkbook.SaveAs ThisWorkbook.Path & "/" & strFileName
On Error GoTo 0
'falls neue Datei geschlossen werden soll
'ActiveWorkbook.Close
End If
Next i
End With
End Sub

Viele Grüße
Martin

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA neue Arbeitsmappe erzeugen

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread