Tabellenblatt aus Exceldatei einlesen

[ilmiomondo]

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

[00202]

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.

[ilmiomondo]

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

[00202]

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.

[ilmiomondo]

Hallo ,
hat geklappt!!! Danke!!!!

Grüße

[ilmiomondo]

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

[00202]

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.