Hallo zusammen bzw. guten Abend
,
ich hätte folgende Frage:
ich habe 6 Exceldateien. Jede Exceldatei besitzt 4 Tabellenblätter.
Das benötigte Tabellenblatt aus jeder Exceldatei besitzt den Namen "Auswertung".
Nun möchte ich in meiner neuen Exceldatei die 6 Tabellenblätter aus den 6 verschiedenen Exceldateien einlesen. Die neue Exceldatei soll als Zusammenfassung dienen.
Am besten soll das Makro auf einen Pfad zurückgreifen. Die Pfade für die 6 Exeldateien können z.B in Spalte A hinterlegt sein. Dadurch kann der Pfad immer wieder neu angepasst werden.
Die 6 Tabellenblätter die eingelesen werden sollen, müssen noch unbenannt werden zu Auswertung 1, Auswertung 2, Auswertung 3, Auswertung 4, Auswertung 5, Auswertung 6.
Kann mir evtl jemand dabei behilflich sein ?
Danke im voraus!
Viele Grüße
Hallo, :19:
Probier mal: :21:
Code:
Option Explicit
Public Sub Main()
Dim wksSheet As Worksheet
Dim strFile As String
Dim strPath As String
Dim lngCalc As Long
Dim lngTMP As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With
For Each wksSheet In ThisWorkbook.Worksheets
If wksSheet.Name Like "Auswert*" Then
wksSheet.Delete
End If
Next wksSheet
'Tabellenblat5tname und Zelladresse anpassen!!!!!!!!
strPath = ThisWorkbook.Worksheets("Berechnung").Range("A1").Value
strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
strFile = Dir$(strPath & "*.xls*")
Do While strFile <> ""
With ThisWorkbook
If strFile <> .Name Then
Application.Workbooks.Open strPath & strFile, ReadOnly:=True
ActiveWorkbook.Worksheets("Auswertung").Copy After:=.Worksheets(.Worksheets.Count)
.Worksheets(.Worksheets.Count).Name = "Auswertung" & lngTMP + 1
Workbooks(strFile).Close False
strFile = Dir$()
Else
strFile = Dir$()
End If
End With
lngTMP = lngTMP + 1
Loop
Fin:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = lngCalc
End With
If Err.Number <> 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
Der Pfad steht in meinem Beispiel im Tabellenblatt "
Berechnung" in Zelle "
A1". Also
anpassen!
Führst du das Makro ein zweites Mal bzw. mehrere Male aus, werden die eingefügten Tabellenblätter
ohne Nachfrage erst
gelöscht und dann wieder
reinkopiert.
Hey Case,
erstmal danke für deine späte Hilfe aber irgendwie funktioniert es noch nicht ganz richtig
Ich bekomme folgende Fehlermeldung:
Error: 52 Dateiname oder - nummer falsch
im Code bezieht er sich auf Excel-Endungen mit xls richtig. ich habe es mal auf xlsx geändert.
ich glaube es liegt an meinem Pfad:
C:\Users\Desktop\Test\test.xlsx
Code:
Public Sub Test()
Dim wksSheet As Worksheet
Dim strFile As String
Dim strPath As String
Dim lngCalc As Long
Dim lngTMP As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With
For Each wksSheet In ThisWorkbook.Worksheets
If wksSheet.Name Like "Auswertung*" Then
wksSheet.Delete
End If
Next wksSheet
'Tabellenblat5tname und Zelladresse anpassen!!!!!!!!
strPath = ThisWorkbook.Worksheets("Tabelle1").Range("A1").Value
strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
strFile = Dir$(strPath & "*.xlsx*")
Do While strFile <> ""
With ThisWorkbook
If strFile <> .Name Then
Application.Workbooks.Open strPath & strFile, ReadOnly:=True
ActiveWorkbook.Worksheets("Auswertung").Copy After:=.Worksheets(.Worksheets.Count)
.Worksheets(.Worksheets.Count).Name = "Auswertung" & lngTMP + 1
Workbooks(strFile).Close False
strFile = Dir$()
Else
strFile = Dir$()
End If
End With
lngTMP = lngTMP + 1
Loop
Fin:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = lngCalc
End With
If Err.Number <> 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
Könnte man die eingelesenen Tabellenblätter mit Auswertung A , Auswertung B , Auswertung C bezeichnen? Müsste man dafür die "1" hier umändern?
lngTMP + 1
Grüße
Hallo, :19:
ja es liegt an deinem
Pfad. Du sollst da den
Pfad angeben -
nicht Pfad und Datei. :21:
Da steht dann also "
C:\Users\Desktop\Test\". Ich meine in der Zelle - also bei mir in A1 - hoffentlich habe ich mich jetzt deutlich genug ausgedrückt. Die Dateinamen sucht der Code dann raus.
Und nein - ich suche
nicht nach "
.xls" - bitte beachte den Stern (
*) am Ende. Ich suche nach "
*.xls", "
*.xlsm", "
*.xlsx", "
*.xlsb"... Verstanden?
Mit
A, B, C... dann so: :21:
Code:
Option Explicit
Public Sub Main()
Dim wksSheet As Worksheet
Dim strFile As String
Dim strPath As String
Dim lngCalc As Long
Dim lngTMP As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With
For Each wksSheet In ThisWorkbook.Worksheets
If wksSheet.Name Like "Auswert*" Then
wksSheet.Delete
End If
Next wksSheet
'Tabellenblat5tname und Zelladresse anpassen!!!!!!!!
strPath = ThisWorkbook.Worksheets("Berechnung").Range("A1").Value
strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
strFile = Dir$(strPath & "*.xls*")
Do While strFile <> ""
With ThisWorkbook
If strFile <> .Name Then
Application.Workbooks.Open strPath & strFile, ReadOnly:=True
ActiveWorkbook.Worksheets("Auswertung").Copy After:=.Worksheets(.Worksheets.Count)
.Worksheets(.Worksheets.Count).Name = "Auswertung " & Chr(lngTMP + 65)
Workbooks(strFile).Close False
strFile = Dir$()
Else
strFile = Dir$()
End If
End With
lngTMP = lngTMP + 1
Loop
Fin:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = lngCalc
End With
If Err.Number <> 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
In dem Pfad sind dann natürlich
nur die Auswertungsdateien -
sonst muss
angepasst werden.
Hallo ,
hat geklappt!!! Danke!!!!
Grüße
Hallo Case,
kurze frage. Könnte man anstatt einlesen auch die Sachen kopieren. Ich habe leider ein Problem mit der Benennung A,B,C,D.
Könnte man die Auswertungstabellenblätter in schon vorhandene Tabellenblätter der Übersichtsdatei reinkopieren?
Grüße
Hallo, :19:
mit ein paar Änderungen so: :21:
Code:
Option Explicit
Public Sub Main()
' Dim wksSheet As Worksheet
Dim strFile As String
Dim strPath As String
Dim lngCalc As Long
Dim lngTMP As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With
' For Each wksSheet In ThisWorkbook.Worksheets
' If wksSheet.Name Like "Auswert*" Then
' wksSheet.Delete
' End If
' Next wksSheet
'Tabellenblat5tname und Zelladresse anpassen!!!!!!!!
strPath = ThisWorkbook.Worksheets("Berechnung").Range("A1").Value
strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
strFile = Dir$(strPath & "*.xls*")
Do While strFile <> ""
With ThisWorkbook
If strFile <> .Name Then
Application.Workbooks.Open strPath & strFile, ReadOnly:=True
ActiveWorkbook.Worksheets("Auswertung").UsedRange.Copy .Worksheets("Auswertung" & lngTMP + 1).Range("A1")
'.Worksheets(.Worksheets.Count).Name = "Auswertung" & lngTMP + 1
Workbooks(strFile).Close False
strFile = Dir$()
Else
strFile = Dir$()
End If
End With
lngTMP = lngTMP + 1
Loop
Fin:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = lngCalc
End With
If Err.Number <> 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
In meiner Gesamtdatei gibt es die Tabellenblätter "
Auswertung1,
Auswertung2,
Auswertung3...".
Das musst du auf
deine Gegebenheiten anpassen.