Arbeitsmappen erstellen VBA

Lesepeter · 2019-05-09T11:23:31+00:00

Hallo zusammen, ich würde gerne mehrere Arbeitsmappen automatisiert per VBA erstellen und unter bestimmten Namen (welche in einer anderen Arbeitsmappe stehen) speichern und schließen. Die Namen der Arbeitsmappen kommen aus Mappe1.xlsx aus der 1.Zeile z.B. ab Spalte D und sollen solange Mappen erstellt werden bis die Zeile keinen Wert mehr enthält z.B. bis Spalte W. Gibt es hier eine Möglichkeit das zu automatisieren über eine Schleife? Danke schon mal für eure Hilfe! Hier das Beispiel https://www.herber.de/bbs/user/129682.xlsx

Hallo Lesepeter,
hier das Grundgerüst für ein solches Makro.
Dieses müsst du bezüglich Dateinamen und Verzeichnisnamen anpassen.
LG
Franz

Sub Kopien_erstellen_von_Mappe()
Dim wkbVorlage As Workbook
Dim wkbNamen As Workbook
Dim wksNamen As Worksheet
Dim bolOpen As Boolean
Dim sPfadKopie As String, sName As String, sDatei_Namen As String, sErweiterung As String
Dim Spalte As Long
Set wkbVorlage = ActiveWorkbook
If MsgBox("von Datei """ & wkbVorlage.Name & """ kopin erstelle?", vbQuestion + vbOKCancel,  _
_
"Kopien erstellen") = vbCancel Then Exit Sub
sPfadKopie = wkbVorlage.Path 'Pfad für Kopien ggf. anders festlegen
'Namenserweiterung der Vorlage ermitteln
With wkbVorlage
sErweiterung = Mid(.Name, InStrRev(.Name, "."))
End With
sDatei_Namen = "MappeNamen.xlsx"   'Arbeitsmappe mit den Namen - Dateiname ggf. anpassen!
'Prüfen, ob Datei mit Namen geöffnet ist
bolOpen = True
For Each wkbNamen In Application.Workbooks
If LCase(wkbNamen.Name) = LCase(sDatei_Namen) Then Exit For
Next
If wkbNamen Is Nothing Then
bolOpen = False
sDatei_Namen = "C:\Users\Public\" & sDatei_Namen  'Verzeichnis anpassen!
Set wkbNamen = Application.Workbooks.Open(Filename:=sDatei_Namen, ReadOnly:=True)
End If
Set wksNamen = wkbNamen.Worksheets(1) 'Nummer oder Name des Tabellenblatts ggf anpassen
With wksNamen
Spalte = 4 'Spalte D
Do Until .Cells(1, Spalte).Text = ""
sName = .Cells(1, Spalte).Text
wkbVorlage.SaveCopyAs Filename:=sPfadKopie & Application.PathSeparator & sName & _
sErweiterung
Spalte = Spalte + 1
Loop
End With
If bolOpen = False Then wkbNamen.Close savechanges:=False
End Sub

Danke! Damit hat es funktioniert.

Option Explicit
Sub Dateien_erstellen()
Dim a As Long, x As Long
Dim objExcel As Object
Dim Pfad As String, DatName As String
Pfad = "C:\Temp\"       'hier Pfad anpassen
a = ThisWorkbook.Sheets("Tabelle1").Cells(1, Columns.Count).End(xlToLeft).Column
For x = 4 To a
DatName = ThisWorkbook.Sheets("Tabelle1").Cells(1, x)
Set objExcel = CreateObject("Excel.Application")
With objExcel
.Visible = False
.Workbooks.Add
.ActiveWorkbook.SaveAs Pfad & DatName
.Quit
End With
Set objExcel = Nothing
Next x
End Sub

Ich benötige dieses Makro als Grundgerüst, um die leeren Blätter in diesem Ordner zu befüllen.
Zur Info: Dafür habe ich dann dieses Makro

Sub Makro1()
strPath = "H:\Aufträge\DATA-WAREHOUSE\Ausleitung MOPF\20170110_Ausleitung\Unformatiert\Test\" ' _
Pfad des Verzeichnisses ggf. anpassen
strExt = "*.xlsx"       'Dateiextension ggf. anpassen
Dim strFile As String
If strPath = "" Then
Exit Sub
Else
strFile = Dir(strPath & strExt)
Do While Len(strFile) > 0
Workbooks.Open Filename:=strPath & strFile
'mach was damit
'deine routine
Workbooks(strFile).Close
strFile = Dir() ' nächste Datei
Loop
End If
End Sub

Forumthread: Arbeitsmappen erstellen VBA

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Arbeitsmappen erstellen VBA

Forumthread: Arbeitsmappen erstellen VBA

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread