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

Hallo,

ist aus meiner Sicht nur mit Makro zu machen.

Hast du es mal mit der AUfzeichnung eines Makros versucht?

Gruß

Helmut

Answer 2

hi sandmann :-)

etwas in der art

gruss nighty

zur zeit wird spalte a kopiert

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
Workbooks(DateiName).Worksheets(1).Range("A1:A" & Workbooks(DateiName).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row).Copy
ThisWorkbook.Worksheets(Workbooks(DateiName).Worksheets(1).Name).Range("A" & ThisWorkbook.Worksheets(Workbooks(DateiName).Worksheets(1).Name).Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
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 3

Hi nighty,

zunächst vielen Dank!

Was Sub DateienLesen() macht ist mir klar. Was machen die Public Sub EventsOff() und Public Sub EventsOn()?

Wie bekomme ich das Makro dazu nicht nur die die Spalte A zu kopieren, sondern die kompletten Inhalte des Blatt. Das verschieben/kopieren des Reiters geht nicht. Die Daten die kopiert werden überschreiben in der Konsolidierungsdatei im entsprechenden Reiter in einer Maske die Daten aus dem Vormonat. Diese Maske ist wiederum mit Formeln verknüpft. Würde das Datenblatt (mit klick auf Reiter dann kopieren/verschieben) kopiert, zerschisst es mir die Formeln. Geht also nur mit copy and paste des Blattinhaltes.

Ein kleines Problem habe ich noch unterschlagen. Die zu kopierenden Dateiblätter sind geschützt. D.h. bevor ich diese kopieren kann, müsste automatisch der Blattschutz aufgehoben werden. Alle Blätter sind mit dem gleichen Passwort geschützt. Kann man das aufheben des Blatzschutzes mit in das Makro aufnehmen.

Wie gesagt, ich bin was das Thema angeht absolut ahnungslos.

Welche Inhalte des Makros, außer den Pfad zum Verzeichnis wo die Dateien liegen, müsste ich für meine Bedürfnisse noch anpassen?

Wenn du mir hier noch helfen könntest, wäre das echt super.

Danke, Danke……Danke…

Grüße

P.S. Saarbauer, dein Vorschlag habe ich ausprobiert. Ich hatte das Gefühl, dass sich so etwas nur schwer über die Makroaufzeichnung realisieren lässt.

Answer 4

hi sandmann :-))

wie gewünscht :-)

Call EventsOff bzw Call EventsOff
schaltet einige ereignissroutinen aus um eine bessere laufzeit zu gewaehrleisten

ActiveSheet.Unprotect ("DeinPasswort")
bzw
ActiveSheet.Protect ("DeinPasswort")
duerfte selbsterklaerend sein

es wird nun der gesammte inhalt als wert kopiert

gruss nighty

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")
.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 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 5

Nachtrag:

Das Einfügen in das Zieldatenblatt funktioniert nur dann, wenn das Zieldatenblatt mit „Strg A“ komplett markiert wird und dann über „Inhalte Einfügen / Werte und Zahlenformate“ die Informationen aus dem Ursprungsblatt eingefügt werden.

Danke!

Answer 6

Hi nighty

hab das Makro laufen lasen bekomme aber immer folgende Fehlermeldung:

Laufzeitfehler ´9´:
Index außerhalb des gültigen Bereichs

und folgende Zeile ist gelb markiert

ThisWorkbook.Worksheets(.Name).Range("A" & thisWorkbook.Worksheets(.Name).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone

Ich vermute, dass es mit meinem Nachtrag zu tun hat. Wenn ich hergehe und manuell versuche die Daten aus der Ursprungsdatei einzufügen geht das nur über komplettes Zieldatenblatt markieren (mit „strg A“) und rechte Maustaste dann Inhalte Einfügen und dann Werte und Zahlenformate einfügen (hat was mit den Formeln in der Zieldatei zu tun). Ich habe das mal als Makro aufgezeichnet was ich da mache:

Sub MarkierenundKopieren()
Windows("12.xls").Activate
Cells.Select
Selection.Copy
Windows("Master Test.xls").Activate
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End Sub

Kannst du mir bitte helfen diesen letzten Schritt zu gehen. Das mit dem Passwortschutz klap übrigens super. Danke dafür! :-))

Grüße
Sandmann

Answer 7

hi sandmann :-)

zitat
deren Bezeichnung der aus der Ursprungsdatei entsprich

dann existiert kein tabellenblatt mit dem ermittelten namen

gruss nighty

Answer 8

hi sandmann :-)

um es unnötig zu komplizieren,schick mir eine musterdatei.jeweils eine quelldatei wie zieldatei

gruss nighty

oberley@t-online.de

Answer 9

hi sanndmann :-)

oder sollen die tabellenblätter erstellt werden ?

bin von ausgegangen das sie schon existieren ?

gruss nighty

Answer 10

hi sandmann :-)

nun mit worksheet erstellung

gruss nighty

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