Inhalte einzelner Tabellenblätter aus unterschiedlichen XLS-Dateien in existierende Reiter einer XLS-Datei kopieren?

Question

Hallo zusammen,

habe folgendes dringendes Problem und keine Idee wie ich es Lösen kann, da ich keine Ahnung von VBA-Programmierung habe. Hab auch schon den einen oder anderen Beitrag hier gelesen, der aber nicht ganz mein Problem löst. Vielleicht kann mir hier ja jemand helfen? Das Thema ist super dringend.

Das Problem lässt sich wie folgt beschreiben:
Aus verschiedenen XLS-Dateien (mit unterschiedlichen Dateinamen), die nur ein einziges Datenblatt (Reiter) enthalten (in jeder Datei ist dieser Reiter anders bezeichnet allerdings eineindeutig mit einem Code z.B. „123456“), sollen die Inhalte der einzelnen Datenblätter/Reiter automatisiert über „Strg A“ und „Strg C“ in einer XLS-Datei kopiert werden. Dabei sollen die Inhalte der einzelnen Dateien bzw. Datenblätter jeweils in ein anderes Datenblatt, deren Bezeichnung der aus der Ursprungsdatei entspricht, über „Strg A“ und „Strg V“ eingefügt werden, D.h., dass die Inhalte des Datenblattes mit dem Code „123456“aus der Ursprungsdatei in die Konsolidierungsdatei unter den Reiter/Datenblatt mit der gleichen Bezeichnung „123456“, wie oben beschrieben, kopiert werden sollen.

Bereits jetzt recht herzlichen Dank für Eure Unterstützung.

Grüße

Answer 1

hi all :-)

*huch*

gruss nighty

das sieht doch huebscher aus :-))

Option Explicit

Sub DateienLesen()
Call EventsOff
Dim DateiName As String
DateiName = Dir("C:\Temp\" & "*.xls")
Do While DateiName <> ""
If ThisWorkbook.Name <> DateiName Then
Workbooks.Open Filename:="C:\Temp\" & DateiName
With Workbooks(DateiName).Worksheets(1)
ActiveSheet.Unprotect ("DeinPasswort")
If SheetExists(.Name) = True Then
ThisWorkbook.Sheets.Add
ThisWorkbook.ActiveSheet.Name = .Name
End If
.Range(.Cells(1, 1), .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, .UsedRange.SpecialCells(xlCellTypeLastCell).Column)).Copy
ThisWorkbook.Worksheets(.Name).Range("A" & ThisWorkbook.Worksheets(.Name).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
ActiveSheet.Protect ("DeinPasswort")
Workbooks(DateiName).Close SaveChanges:=True
End With
End If
DateiName = Dir
Loop
Call EventsOn
End Sub

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

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 Nighty,

sorry dass ich mich seit November nicht mehr gemeldet habe. War zwischenzeitlich schwer erkrankt.

Leider konnte ich das Problem bis heute nicht lösen. Ich hab dir daher, wie von dir vorgeschlagen, eine Mail mit allen Informationen an die von dir o.g. Mailadresse gesendet.

Würde mich freuen, wenn du mir helfen könntest, das Problem zu lösen.

Grüße
Sandmann