Arbeitsmappen erstellen VBA

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

Sub aaa() Dim r As Range, wb As Workbook Dim p As String Application.ScreenUpdating = False p = ThisWorkbook.Path 'anpassen If Right(p, 1) Application.PathSeparator Then p = p & Application.PathSeparator With Workbooks("Mappe1.xlsx").Sheets(1) For Each r In .Range(.Cells(1, 4), .Cells(1, Columns.Count).End(xlToLeft)) Set wb = Workbooks.Add wb.SaveAs p & r wb.Close Next r End With End Sub

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

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Arbeitsmappen erstellen VBA

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

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread