Daten übertragen aus mehreren Dateien und mehreren Sheets
21.01.2020 09:51:21
Markus
ich hoffe ihr könnt mir helfen. Ich komme aktuell nicht weiter, weil ich nicht weiß, wo der Fehler liegt. Ich habe 3 Dateien und möchte diese nacheinander öffnen und die Daten aus den Tabellen ganz einfach über kopieren in die Masterdatei einfügen. Ich habe mehrere Reiter pro Datei, die alle abgearbeitet werden sollen. In der Masterdatei sollen die kopierten Bereiche untereinander eingefügt werden. (pro Reiter 3 Stück / jeweils 1 Bereich aus jeder Datei)
Aber anscheinend kopiert er mir nur aus der ersten Datei den Bereich und auch nur den ersten Teil. Den zweiten macht er gar nicht. Ich habe versucht den Code ziemlich einfach zu halten.
Ich danke euch schon einmal für eure Hilfe.
LG Markus
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim wsdatei As Worksheet
Dim pfad As String
Dim datei As String
Dim bereichkopieren As Range
Dim wb As Workbook
Dim bereichstückzahl As Range
Application.DisplayAlerts = False
' Erste Datei CNC öffnen und kopieren ---------------------------------------------------------- _
pfad = ThisWorkbook.Path
datei = Dir(pfad & "\" & "20200115_Fehlerauswertung_CNC.xlsx")
Workbooks.Open pfad & "\" & datei, ReadOnly:=True
Set wb = Workbooks(datei)
Set bereichstückzahl = Range("C19:DX19")
Set bereichkopieren = Range("C6:DX18")
For Each wsdatei In wb.Worksheets
bereichkopieren.Copy
ThisWorkbook.Activate
For Each ws In ThisWorkbook.Worksheets
If ws.Name = wsdatei.Name Then
Range("C6").Select
ActiveCell.PasteSpecial
End If
Next ws
'wb.Activate
Next wsdatei
For Each wsdatei In wb.Worksheets
bereichstückzahl.Copy
ThisWorkbook.Activate
For Each ws In ThisWorkbook.Worksheets
If ws.Name = wsdatei.Name Then
Range("C45").Select
ActiveCell.PasteSpecial
End If
Next ws
wb.Activate
Next wsdatei
wb.Close
' Zweite Datei Pressen öffnen und kopieren ----------------------------------------------------- _
datei = Dir(pfad & "\" & "20200115_Fehlerauswertung_Pressen.xlsx")
Workbooks.Open pfad & "\" & datei, ReadOnly:=True
Set wb = Workbooks(datei)
Set bereichstückzahl = Range("C19:DX19")
For Each wsdatei In wb.Worksheets
Set bereichkopieren = Range("C6:DX18")
bereichkopieren.Copy
ThisWorkbook.Activate
For Each ws In ThisWorkbook.Worksheets
If ws.Name = wsdatei.Name Then
Range("C19").Select
ActiveCell.PasteSpecial
End If
Next ws
wb.Activate
Next wsdatei
For Each wsdatei In wb.Worksheets
bereichstückzahl.Copy
ThisWorkbook.Activate
For Each ws In ThisWorkbook.Worksheets
If ws.Name = wsdatei.Name Then
Range("C46").Select
ActiveCell.PasteSpecial
End If
Next ws
wb.Activate
Next wsdatei
wb.Close
' Dritte Datei Versand öffnen und kopieren ----------------------------------------------------- _
datei = Dir(pfad & "\" & "20200115_Fehlerauswertung_Versand.xlsx")
Workbooks.Open pfad & "\" & datei, ReadOnly:=True
Set wb = Workbooks(datei)
Set bereichstückzahl = Range("C19:DX19")
For Each wsdatei In wb.Worksheets
Set bereichkopieren = Range("C6:DX18")
bereichkopieren.Copy
ThisWorkbook.Activate
For Each ws In ThisWorkbook.Worksheets
If ws.Name = wsdatei.Name Then
Range("C32").Select
ActiveCell.PasteSpecial
End If
Next ws
wb.Activate
Next wsdatei
For Each wsdatei In wb.Worksheets
bereichstückzahl.Copy
ThisWorkbook.Activate
For Each ws In ThisWorkbook.Worksheets
If ws.Name = wsdatei.Name Then
Range("C47").Select
ActiveCell.PasteSpecial
End If
Next ws
wb.Activate
Next wsdatei
wb.Close
Application.DisplayAlerts = True
End Sub