Aus mehreren Excel Dateien immer ein bestimmtes Arbeitsblatt kopieren und in einer Datei in ein Arbeitsblatt einfügen.

Question

Hallo an alle,

ich habe das folgende Problem, dass ich -wie oben beschrieben- aus vielen Excel Dateien immer aus einem bestimmten Arbeitsblatt Namens "temperature" den ganzen Inhalt von C1 an sammeln möchte.

Dabei sollen die Daten hintereinander, beginnend bei C1 fortgeschrieben werden, also aus der ersten Datei alles von C bis beispielhaft XY, aus der zweiten Datei beginnend bei XZ bis ACA usw

Bisher habe ich leider keine Lösungen finden können und würde mich über Hilfe sehr freuen.

Viele Grüße

Answer 1

Hallo Mark!

Download ging nicht .-)
Schick die beiden Dateien bitte an meine Email,Oberley@T-Online.de

Gruss Nighty

Answer 2

Hallo Nighty,

habe ich soeben gemacht.

Gruß Mark

Answer 3

Hallo Community .-)

Nach kontakt mit dem Fragesteller,ist folgende Lösung entstanden!

Sub DateienLesen()
Call EventsOff
Dim DateiName As String, WksName As String, Dpfad As String, Deindung As String
Dim Lspalte As Long
Dpfad = CreateObject("Shell.Application").BrowseForFolder(0, "Ordner auswählen", &H1000, 17).items().Item().Path & "\"
Deindung = "*.xlsm"
WksName = "temperature"
DateiName = Dir(Dpfad & Deindung)
Lspalte = 3
Do While DateiName <> ""
If ThisWorkbook.Name <> DateiName Then
Workbooks.Open Filename:=Dpfad & DateiName
If SheetExists("" & WksName) = True Then
Worksheets("" & WksName).Range(Worksheets("" & WksName).Cells(1, 3), Worksheets("" & WksName).Cells(Worksheets("" & WksName).UsedRange.SpecialCells(xlCellTypeLastCell).Row, Worksheets("" & WksName).UsedRange.SpecialCells(xlCellTypeLastCell).Column)).Copy
ThisWorkbook.Worksheets(1).Cells(1, Lspalte).PasteSpecial Paste:=xlValues, Operation:=xlNone
Lspalte = ThisWorkbook.Worksheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Column + 1
End If
Workbooks(DateiName).Close SaveChanges:=False
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
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

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

Gruß Nighty