40 Exceldateien mit 1 Arbeitsblatt automatisch in einer Datei als 40 Arbeitsblätter kopieren

Question

Hallo,
ich muss 40 Dateien mit jeweils 1 Arbeitsblatt welches den gleichen Namen hat wie die Datei in eine neue Datei einfügen.
Dann ist der Name der Datei gleich dem des Arbeitsblattes.

Es sollte automatisch unter Excel 2007 gehen ..

Geht so etwas ??

Answer 1

hi all ^^

ein Beispiel :-)

gruss nighty

Sub WorksheetCopy()
Call EventsOff
Dim DateiName As String
DateiName = Dir("D:\Temp\" & "*.xls")
Do While DateiName <> ""
If ThisWorkbook.Name <> DateiName Then
Workbooks.Open Filename:="D:\Temp\" & DateiName
Workbooks(DateiName).Worksheets(Mid(DateiName, 1, Len(DateiName) - 4)).Copy Before:=ThisWorkbook.Sheets(1)
Workbooks(DateiName).Close SaveChanges:=True
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

Answer 2

hi all ^^

fehlerroutine hinzugefuegt

gruss nighty

Sub WorksheetCopy()
Call EventsOff
Dim DateiName As String, Meldung As String
Dim Schalter As Integer
If PfadExists("D:\Temp\") = True Then
DateiName = Dir("D:\Temp\" & "*.xls")
Do While DateiName <> ""
If ThisWorkbook.Name <> DateiName Then
If SheetExists(Mid(DateiName, 1, Len(DateiName) - 4)) = False Then
Workbooks.Open Filename:="D:\Temp\" & DateiName
If SheetExists(Mid(DateiName, 1, Len(DateiName) - 4)) = True Then
Workbooks(DateiName).Worksheets(Mid(DateiName, 1, Len(DateiName) - 4)).Copy Before:=ThisWorkbook.Sheets(1)
Else
Schalter = 1
End If
Else
Schalter = 2
End If
End If
If Schalter = 1 Then
Meldung = MsgBox("Wks " & DateiName & " Kopie fehlgeschlagen,es wird die nächste Datei gelesen !", , "Fehler")
Workbooks(DateiName).Close SaveChanges:=True
End If
If Schalter = 2 Then Meldung = MsgBox("Wks " & DateiName & " Einfügen fehlgeschlagen,es wird die nächste Datei gelesen !", , "Fehler")
Schalter = 0
DateiName = Dir
Loop
Else
Meldung = MsgBox("Falsche Quellpfad oder nicht vorhanden !", , "Fehler")
End If
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

Public Function PfadExists(strName As String) As Boolean
On Error Resume Next
If Dir(strName) <> "" Then PfadExists = True
End Function

Answer 3

hi all ^^

diese zeile

If Schalter = 0 Then Workbooks(DateiName).Close SaveChanges:=True

noch einfuegen,ueber

schalter=0

gruss nighty