Tabellenblätter in eine bestehende Exceldatei einfügen (ans Ende)

Question

Hallo zusammen,

ein Kollege hat mir den Tip gegeben Excel Dateien mittels Makros zusammenzufügen.

Wir haben demnächst ca. 850 Excel Dateien aus denen je nach Name (bis zum 5. "_" muss alles gleich sein) die Tabellenblätter in die Kopie einer bzw. mehrere bereits bestehende Excel Dateien eingefügt werden müssen (siehe weiter unten).

Dies sollte eigentlich auch mitteln Makro funktionieren.

Also hier mal die Minimalversion:
- Das Makro zieht sich alle Tabellenblätter (eins je Datei) die im selben Verzeichnis sind wie die ausführende Excel Datei ans Ende der Excel Datei (jedoch vor dem ausgeblendeten).

Nun Steigerungen:
1.
Das Makro wähl je nach Dateiname welche Tabellenblätter es einfügt. Bis zum fünften unterstrich sollen die Namen der zusammengefassten Tabellenblätter identisch sein.
2.
Das makro erstellt mehrere neue Exceldatei bzw. Kopien der aktuellen Datei in die er dann die jeweiligen Tabellenblätter einfügt.
3.
Das Makro benennt die neuen Dateie wie der Name der Dateien zwischen dem dritten und fünften Unterstrich.

Ich hoffe es kann mir jemand helfen. Ich habe das letzte mal vor ca. 10 Jahren mit Makros gearbeitet und dabei ging es nur um Zeilen einfügen etc. :)

Ich wäre glücklich, wenn die Minimalversion realisierbar wäre. Alles andere wären die ü Tüpfelchen.

Vielen Dank im voraus!

Vg
Evren

Answer 1

hi evren ^^

dann tasten wir uns doch einmal ein wenig ran :-)

gruss nighty

ein erstes beispiel bzw versuch

aus einem verzeichnis(zur zeit C:\Temp)werden von einer unbestimmten anzahl an dateien das erste worksheet kopiert und in der mappe eingefuegt von dem das makro gestartet worden ist,
dann umbenannt mit den ersten 8 zeichen des dateinamens

Option Explicit
Sub DateienLesen()
Call EventsOff
Dim DateiName As String, Meldung As String
DateiName = Dir("C:\Temp\" & "*.xls")
Do While DateiName <> ""
If ThisWorkbook.Name <> DateiName And SheetExists("" & Mid(DateiName, 1, 8)) = False Then
Workbooks.Open Filename:="C:\Temp\" & DateiName
Workbooks(DateiName).Worksheets("Tabelle1").Copy After:=Workbooks(ThisWorkbook.Name).Worksheets(Sheets.Count)
ActiveSheet.Name = Mid(DateiName, 1, 8)
Workbooks(DateiName).Close
Else
Meldung = MsgBox("Ein Worksheet mit dem Namen " & Mid(DateiName, 1, 8) & " gibt es schon")
End If
DateiName = Dir
Loop
Call EventsOn
End Sub

Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Public Function SheetExists(strName As String) As Boolean
On Error Resume Next
SheetExists = Not Worksheets(strName) Is Nothing
End Function

Answer 2

Hallo Nighty,

Vielen dank für die Antwort :-) Ich hatte bereits aus ganz vielen verschiedenen Quellen ein makro zusammengebastelt, welches uns bereits viel Arbeit erspart hat. Es war zwar nicht alles voll automatisiert, jedoch war der Rest leicht zu bewältigen.

Sub Start()
Dim WbZiel As Workbook
Dim WbQuelle As Workbook
Dim WsQuelle As Worksheet
Dim strPfad As String
Dim strDat As String
Dim i As Integer

Application.ScreenUpdating = False
Application.EnableEvents = False

'Importdatei:
Set WbZiel = ThisWorkbook

'Quellpfad anbeben:
strPfad = "Q:\FLPS Toolbox\Dokumente Berichtemanager\Test"

'Backslash:
strPfad = IIf(Right(strPfad, 1) <> "\", strPfad & "\", strPfad)

'Importdateien:
strDat = Dir(strPfad & "*.xls")

'Schleife über alle Dateien des Ordners
Do While strDat <> ""
Set WbQuelle = Workbooks.Open(Filename:=strPfad & strDat, ReadOnly:=True)
For Each WsQuelle In WbQuelle.Worksheets 'Schleife über alle Tabellenblätter
i = i + 1
WsQuelle.Copy After:=WbZiel.Sheets(WbZiel.Sheets.Count)
a = Right(WsQuelle.Parent.Name, Len(WsQuelle.Parent.Name) - InStr(WsQuelle.Parent.Name, "_"))
b = Right(a, Len(a) - InStr(a, "_"))
c = Right(b, Len(b) - InStr(b, "_"))
d = Right(c, Len(c) - InStr(c, "_"))
e = Right(d, Len(d) - InStr(d, "_"))
f = Left(e, InStr(e, " "))
ActiveSheet.Name = (f)
Next
WbQuelle.Close savechanges:=False
If i Mod 200 = 0 Then
WbZiel.Save
End If
strDat = Dir()
Loop

Application.EnableEvents = True
Application.ScreenUpdating = True
Set WbZiel = Nothing
Set WbQuelle = Nothing
Set WsQuelle = Nothing
'End Sub

'Sub ProfitcenterName()
Dim wksL As Worksheet
Dim wksR As Worksheet

Set wksL = ActiveWorkbook.Worksheets(1)
Set wksR = ActiveWorkbook.Worksheets(6)
a = wksR.Range("C7").Value
b = Right(a, Len(a) - InStr(a, "/"))
c = Right(b, Len(b) - InStr(b, "/"))
d = Right(c, Len(c) - InStr(c, "/"))
NameFertig = Left(d, InStr(d, "/") - 1)
wksL.Range("C6").Value = NameFertig

'End Sub


'Sub Fenster_fixieren()


'End Sub

'Sub Tabelle verschieben()

Sheets(i + 3).Move Before:=Sheets("PC-DUMMY")

' End Sub

'Sub Tabelle löschen()

Application.DisplayAlerts = False
Sheets("PC-DUMMY").Delete
Application.DisplayAlerts = True

'End Sub

'Sub Blattschutz()

If ThisWorkbook.Worksheets(1).ProtectContents = True Then
For Each wks In ThisWorkbook.Worksheets
'wks.Unprotect Password:="**"
Next 'wks
Else
For Each wks In ThisWorkbook.Worksheets
wks.Protect Password:="**"
Next 'wks
End If

Dim wb As Workbook
Dim NeuerName As String

Set wb = ActiveWorkbook
Set ws = ActiveSheet

NewName = NameFertig
With ActiveWorkbook
.SaveAs "Q:\ControlK\Wirtschaftspläne\WiPl2010+2011\Planungsdateien\GuV\" & NewName, wb.FileFormat
'.Close
End With
wb.Activate
Kill "Q:\FLPS Toolbox\Dokumente Berichtemanager\Test\*.xls"
Workbooks.Open Filename:="Q:\FLPS Toolbox\Dokumente Berichtemanager\Masterdateien\Profitcenterknoten.xls", ReadOnly:=False
End Sub

Momentan habe ich das Problem dass ich aus den erstellten Dateien noch Summenblätter bilden muß. Natürlich nur aus den jeweils ersten Tabellenblättern (immer ca. 1-40 Dateien). Ich versuche das mal zu lösen, Wenn jemand Rat weiss... PS: Der jeweilige Bereich muss ausgewählt werden, da auf dem Summenblatt Zwischenspalten eingefügt werden.

Grüße
Evren