142 Aufrufe
Gefragt in Tabellenkalkulation von jojo1978 Einsteiger (52 Punkte)
ich möchte mehrere tabellen aus einem Ordner in eine andere übertragen. Die tabellen sind gleich ausgebaut und ich möchte das arbeitsblatt "neu" in dann Tabelle "Bus1" Bus2 usw  zuweisen ich hab mal so was ähnliches gefunden. Geht aber unter exel 2016 nicht.  Kann mir jemand helfen. Vielen Dank.                  Sub FilesListen()
Call EventsOff
Dim Dateien As Integer
Dim DateiName As String
Dim zaehler As Boolean
With Application.FileSearch
.NewSearch
.LookIn = "D:\Temp\"
.SearchSubFolders = True
.Filename = "*.xls"
If .Execute() > 0 Then
For Dateien = 1 To .FoundFiles.Count
DateiName = Dir(.FoundFiles(Dateien))
If DateiName <> ThisWorkbook.Name Then
Workbooks.Open Filename:=.FoundFiles(Dateien)
If zaehler = False Then
zeile = 13
Else
zeile = ThisWorkbook.Sheets("AngebotAuflistung").Cells(Rows.Count, 9).End(xlUp).Row + 1
End If
Workbooks(DateiName).Sheets("Angebot").Range("K12:L12").Copy ThisWorkbook.Sheets("AngebotAuflistung").Range("I" & zeile & ":J" & zeile)
zaehler = True
Workbooks(DateiName).Close SaveChanges:=True
End If
Next Dateien
End If
End With
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

8 Antworten

+1 Punkt
Beantwortet von nighty Experte (6.2k Punkte)
Hallo Community

Anrede und Gruß wäre auch nicht schlecht!

Gruß Nighty

Quelle

Alle Dateien eines ausgewählten Ordners

Worksheeets(1)

Genutzter Bereich

Ziel

ThisWorkbook

Erstellung von einem Worksheets,mit dem Namen "Bus 1" mit fortlaufender Numerierung

Einfügen der zuvor kopierten Daten

und nächste Datei

Sub DateienLesen()
    Call EventsOff
    Dim Index As Integer
    Dim Daten() As Variant
    Dim DateiName As String, Dpfad As String
    Dpfad = OrdnerAuswahl
    DateiName = Dir(Dpfad & "*.xls")
    Do While DateiName <> ""
        If ThisWorkbook.Name <> DateiName Then
            Index = Index + 1
            ThisWorkbook.Worksheets.Add after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
            ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = "Bus " & Index
            Workbooks.Open Filename:=Dpfad & DateiName
            Workbooks(DateiName).Worksheets(1).UsedRange.Copy
            ThisWorkbook.Worksheets("Bus " & Index).Range("A1").PasteSpecial Paste:=xlValues, Operation:=xlNone
            Workbooks(DateiName).Close SaveChanges:=False
            ThisWorkbook.Worksheets("Bus " & Index).Range("A1").Select
        End If
        DateiName = Dir
    Loop
    Call EventsOn
End Sub
Function OrdnerAuswahl() As String
    On Error GoTo FehlerRoutine
    Dim AppShell As Object
    Dim BrowseDir As Variant
    Set AppShell = CreateObject("Shell.Application")
    Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
    OrdnerAuswahl = BrowseDir.items().Item().Path & "\"
FehlerRoutine:
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
0 Punkte
Beantwortet von jojo1978 Einsteiger (52 Punkte)
wieder angezeigt von jojo1978
Hallo Nighty. Dankeschön für deine Antwort.

Ich hab mich vielleicht etwas falsch ausgedrückt.
In den Arbeitsmappen wo ich ein Tabellenblatt auslesen möchte heißt "neu".
Und dieses Tabellenblatt "neu" möchte ich dann in meiner Arbeitsmappe in das vorhandene Tabellenblatt "Bus1" kopieren. Bei der nächsten Datei dann in das vorhandene Tabellenblatt "Bus2" usw.
Es sollen keine neuen tabellenblätter erstellt werden da sonst meinen Verknüpfung der Bezug fehlt.

Vielen dank wenn du mir weiter helfen kannst.
Muss gerade meine Nachrichten mit dem Handy schreiben. Da mein Festnetzanschluss noch dauert Grüße jojo
0 Punkte
Beantwortet von nighty Experte (6.2k Punkte)
Hallo jojo

Dann so!

Gruß Nighty

Sub DateienLesen()
    Call EventsOff
    Dim Index As Integer
    Dim DateiName As String, Dpfad As String
    Dpfad = OrdnerAuswahl
    DateiName = Dir(Dpfad & "*.xls")
    Do While DateiName <> ""
        If ThisWorkbook.Name <> DateiName Then
            Index = Index + 1
            If SheetExists("Bus" & Index) = True Then
                Workbooks.Open Filename:=Dpfad & DateiName
                If SheetExists("neu") = True Then
                    Workbooks(DateiName).Worksheets("neu").UsedRange.Copy
                    ThisWorkbook.Worksheets("Bus" & Index).Range("A1").PasteSpecial Paste:=xlValues, Operation:=xlNone
                End If
                Workbooks(DateiName).Close SaveChanges:=False
                ThisWorkbook.Worksheets("Bus" & Index).Range("A1").Select
            End If
        End If
        DateiName = Dir
    Loop
    Call EventsOn
End Sub
Function SheetExists(strName As String) As Boolean
    On Error Resume Next
    SheetExists = Not Worksheets(strName) Is Nothing
End Function
Function OrdnerAuswahl() As String
    On Error GoTo FehlerRoutine
    Dim AppShell As Object
    Dim BrowseDir As Variant
    Set AppShell = CreateObject("Shell.Application")
    Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
    OrdnerAuswahl = BrowseDir.items().Item().Path & "\"
FehlerRoutine:
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
0 Punkte
Beantwortet von nighty Experte (6.2k Punkte)
Hallo Jojo

Sollte eines von beiden Worksheets nicht existieren,werden keine Daten übertragen(ohne Fehlermeldung)

Gruß Nighty
0 Punkte
Beantwortet von jojo1978 Einsteiger (52 Punkte)
Hallo Nighty,

Leider funktioniert das nicht ich bekomme die Meldung Laufzeitfehler 1004 für diese Aktion müssen alle Zellen dieselbe größe haben. Was muss ich ändern? das arbeitsblatt wo ich kopieren möchte hat verbundene Zellen.
Danke für deinen Lösungsvorschlag.

Grüße jojo
0 Punkte
Beantwortet von nighty Experte (6.2k Punkte)
Hallo jojo

Dann so!

Gruß Nighty

Sub DateienLesen()
    Call EventsOff
    Dim Index As Integer
    Dim DateiName As String, Dpfad As String
    Dpfad = OrdnerAuswahl
    DateiName = Dir(Dpfad & "*.xls")
    Do While DateiName <> ""
        If ThisWorkbook.Name <> DateiName Then
            Index = Index + 1
            If SheetExists("Bus" & Index) = True Then
                Workbooks.Open Filename:=Dpfad & DateiName
                If SheetExists("neu") = True Then
                    Workbooks(DateiName).Worksheets("neu").UsedRange.Copy
                    ThisWorkbook.Worksheets("Bus" & Index).Range("A1").PasteSpecial Paste:=xlFormulas, Operation:=xlNone
                End If
                Workbooks(DateiName).Close SaveChanges:=False
                ThisWorkbook.Worksheets("Bus" & Index).Range("A1").Select
            End If
        End If
        DateiName = Dir
    Loop
    Call EventsOn
End Sub
Function SheetExists(strName As String) As Boolean
    On Error Resume Next
    SheetExists = Not Worksheets(strName) Is Nothing
End Function
Function OrdnerAuswahl() As String
    On Error GoTo FehlerRoutine
    Dim AppShell As Object
    Dim BrowseDir As Variant
    Set AppShell = CreateObject("Shell.Application")
    Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
    OrdnerAuswahl = BrowseDir.items().Item().Path & "\"
FehlerRoutine:
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
+1 Punkt
Beantwortet von nighty Experte (6.2k Punkte)
Hallo Jojo

Für die Zukunft,verbundene Zellen sind schlecht zu händeln in vba

bzw sehr Zeit intensiv zur Laufzeit.

Also in Zukunft andere Wege suchen!

Gruß Nighty
0 Punkte
Beantwortet von jojo1978 Einsteiger (52 Punkte)
Hallo Nighty

Danke für deine Hilfe
...