Aus kopierten Tabellenblättern neue Dateien erstel

Peter · 2009-01-17T16:40:00+00:00

Hallo Leute, ich habe ein Excel Problem und hoffe es ist mittels VBA zu lösen. Ich muss aus 200 Dateien 2 bestimmte Tabellenblätter kopieren. Diese kopierten Tabellenblätter einer jeden Datei sollen in eine Vorlagendatei kopiert werden und anschließend als neue Datei gespeichert werden. (Es sollen also quasi 200 neue Dateien auf Basis der Vorlagendatei entstehen) Die Tabellenblätter sind alle gleich aufgebaut; der Name der zur Speicherung benutzt werden soll, steht in einer Zelle des ersten zu kopierenden Tabellenblattes. Es sollte also folgendes passieren: 1. Datei öffnen 2. Tabellenblätter kopieren 3. Kopierte Tabellenblätter in Vorlagendatei einfügen 4. Vorlagendatei unter dem Namen, der in der Zelle des 1. Tabellenblattes steht, speichern. Leider bin ich ein absoluter Neuling auf dem VBA Gebietich wäre auch super dankbar, wenn ihr mir helfen könntet.

Hallo,
habe bei mir mal externe Verknüpfungen eingefügt, bei mir kommt solch eine Meldung nicht.
Versuche es mal hiermit, kann es aber nicht versprechen,
müsste dies unter Deiner Version testen und die habe ich jetzt im Moment nicht zur Verfügung.

Option Explicit

Sub SucheDatei()
Dim Fso, Ordner, varDatei
Dim SucheDatei As String, strVorL As String, strDateien As String
Dim strSpeicherOrt As String, strDateiName As String
Dim myVorLage As Workbook, tempDatei As Workbook
Dim myTabelle(1) As String
Dim myCalc As Integer

strVorL = "J:\1 Forum\TestVorlage.xlt" 'Pfad für Vorlage 
strDateien = "J:\1 Forum\Vorlage" 'wo Deine Dateien liegen 
strSpeicherOrt = "C:\NeuerOrdner\" 'wo die Dateien hin sollen 
myTabelle(0) = "Tabelle1" 'erste Tabelle die kopiert werden soll 
myTabelle(1) = "Tabelle2" 'zweite Tabelle die kopiert werden soll 
SucheDatei = ".xls" 'Suchfilter, hier Exceldateien bis xl2003 

With Application
  myCalc = .Calculation
 .EnableEvents = False
 .Calculation = xlCalculationManual
 .ScreenUpdating = False
 .DisplayAlerts = False
 .StatusBar = "Bitte warten"
        
        Set Fso = CreateObject("Scripting.FileSystemObject")
        Set Ordner = Fso.getfolder(strDateien)
        
        'Schleife über alle Dateien im Ordner 
        For Each varDatei In Ordner.Files
          'Dateifilter, Platzhalter verwenden 
         If varDatei Like "*" & SucheDatei Then
            Set myVorLage = Workbooks.Open(strVorL)
            Set tempDatei = Workbooks.Open(varDatei, , True)
        
            tempDatei.Sheets(myTabelle).Copy _
            After:=myVorLage.Sheets(myVorLage.Sheets.Count)
            strDateiName = Replace(tempDatei.Sheets(myTabelle(0)).Range("A1"), "Speichern", "")
            
            myVorLage.SaveAs strSpeicherOrt & strDateiName & ".xls"
            
            
            tempDatei.Close False
            myVorLage.Close False
         End If
        Next varDatei
     
     
    .Calculation = myCalc
    .EnableEvents = True
    .StatusBar = False
    .DisplayAlerts = True
    .ScreenUpdating = True
End With


End Sub

Gruß Tino

Hallo ich hab zu dem Makro nochmals ne Frage:
Wenn es anstelle von zwei Tabellenblätter nun vier sind, die kopiert werden sollen, wie muss ich hierzu den Code verändern?
Ich habe probiert 2 weitere mysheet variablen zu deklarieren, aber es kommt nun eine Fehlermeldung: "mehrfachdeklaration im akutellen Gültigkeitsbereich"
Option Explicit


Sub SucheDatei()
Dim Fso, Ordner, varDatei
Dim SucheDatei As String, strVorL As String, strDateien As String
Dim strSpeicherOrt As String
Dim myVorLage As Workbook, tempDatei As Workbook
Dim mytabelle(1) As String
Dim mytabelle(2) As String    'dies wurde von mir eingetragen
Dim mytabelle(3) As String    'dies wurde von mir eingetragen
strVorL = "C:\Users\Der Don\Desktop\Makrotest\Vorlage\vorlage.xls" 'Pfad für Vorlage
strDateien = "C:\Users\Der Don\Desktop\Makrotest\DCF" 'wo Deine Dateien liegen
strSpeicherOrt = "C:\Users\Der Don\Desktop\Makrotest\Speichern\" 'wo die Dateien hin sollen
mytabelle(0) = "cash flow (Q1_2009)" 'erste Tabelle die kopiert werden soll
mytabelle(1) = "Ausgaben Planung (Q1_2009)" 'zweite Tabelle die kopiert werden soll
mytabelle(2) = "Neu"          'dies wurde von mir eingetragen
mytabelle(3) = "Neu1"         'dies wurde von mir eingetragen
SucheDatei = ".xls" 'Suchfilter, hier Exceldateien bis xl2003
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.StatusBar = "Bitte warten"
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Ordner = Fso.getfolder(strDateien)
'Schleife über alle Dateien im Ordner
For Each varDatei In Ordner.Files
'Dateifilter, Platzhalter verwenden
If varDatei Like "*" & SucheDatei Then
Set myVorLage = Workbooks.Open(strVorL)
Set tempDatei = Workbooks.Open(varDatei, , True)
tempDatei.Sheets(myTabelle).Copy _
After:=myVorLage.Sheets(myVorLage.Sheets.Count)
myVorLage.SaveAs strSpeicherOrt & tempDatei.Sheets(tabelle(0)).Range("c5") & ".xls"
tempDatei.Close False
myVorLage.Close False
End If
Next varDatei
.StatusBar = False
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub

Aus kopierten Tabellenblättern neue Dateien erstel

Forumthread: Aus kopierten Tabellenblättern neue Dateien erstel

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Aus kopierten Tabellenblättern neue Dateien erstel

Forumthread: Aus kopierten Tabellenblättern neue Dateien erstel

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread