Doppel Datenübernahme bei FSO Schleife

  • Excel

Es gibt 6 Antworten in diesem Thema. Der letzte Beitrag () ist von Marco123.

    Doppel Datenübernahme bei FSO Schleife

    Moin Forum,

    folgende Sitation bereitet mir grade etwas Kopfschmerzen:
    Per FSO-Schleife importiere ich sämtliche Daten aller in einem Ordner abgelegten Excel-Dateien in eine Mastertabelle.
    Aus mit bisher unbekannten Gründen werden einige Daten jedoch doppelt übernommen.

    Hier mein aktueller Code:

    Visual Basic-Quellcode

    1. Const Pfad = "C:\Users\ABC\Desktop\Projekt\" 'Pfad der einzulesenden Dateien
    3. Sub Daten_auslesen()
    5. Dim FSO
    6. Dim Datei
    7. Dim Ordner
    8. Dim Col As New Collection
    9. Dim Element
    10. Dim WB As Workbook
    12. On Error Resume Next
    14. Set FSO = CreateObject("Scripting.Filesystemobject")
    16. Set Ordner = FSO.getfolder(Pfad)
    18. 'Bildschirmaktualisierung ausschalten
    19. With Application
    20. .ScreenUpdating = False
    21. .Calculation = xlCalculationManual
    22. .EnableEvents = False
    23. End With
    25. 'Tabellen leeren
    26. Tabelle1.Columns("A:E").ClearContents
    28. 'Schleife über alle Dateien im Ordner laufen lassen
    29. For Each Datei In Ordner.Files
    31. Select Case LCase(FSO.GetExtensionName(Datei))
    33. 'Format welches gesucht werden soll
    34. Case "xlsm"
    36. 'Alle Excel-Dateien in eine Collection.Die anderen ignorieren.
    37. Col.Add Datei
    39. End Select
    41. Next
    43. 'Schleife für Datenübernahme
    44. For Each Element In Col
    46. 'Quelle bestimmen / öffnen
    47. Set WB = Workbooks.Open(Element.Path, ReadOnly:=True)
    49. '=========================================
    51. 'Bereich 1 auswählen
    52. WB.Worksheets("Tabelle1").Range("E12:G12" & Sheets("Tabelle1").Cells(Rows.Count, 2).End(xlUp).Row).Copy
    54. 'Ablage 1 in Ziel
    55. ThisWorkbook.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 'AndNumberFormats
    57. 'Zwischenspeicher leeren
    58. Application.CutCopyMode = False
    60. '=========================================
    62. 'Quelle schließen ohne zu speichern
    63. WB.Close SaveChanges:=False
    65. Next
    67. 'Bildschirmaktualisierung einschalten
    68. With Application
    69. .ScreenUpdating = True
    70. .Calculation = xlCalculationAutomatic
    71. .EnableEvents = True
    72. End With
    74. End Sub


    Habt Ihr evtl. eine Ahnung (oder Lösung) wo die Ursache für die teils doppelte Datenübernahme liegt?

    Vielen Dank im Voraus für Eure Unterstützung

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „Marco123“ ()

    Hi Petaod,

    Danke für die schnelle Reaktion.

    Eine doppelte Ablage war auch meine erste Vermutung.
    Mehrfache Überprüfungen ergaben jedoch, dass das nicht der Fall ist. Alle Daten sind nur einmal vorhanden.

    Ich hab momentan die Dopplungen per Formel und Filter ausgeblendet, daher brennen sie mir nicht mehr ganz so unter den Nägeln.
    Da ich den o.g. Code aber höchstwahrscheinlich noch für andere Anwendungen heranziehen werde, würd ich die Ursache des ganzen gerne herausfinden.

    Konntest Du den im Code irgendwelche garvierenden Schnitzer erkennen?
    (Muss nicht unbedingt mit dem Thema zusammenhängen. Ich bin für jede Art von Verbesserungsvorschlägen dankbar.)

    Dann hilft nur schreitweise durch die Schleife gehen und schauen, wann die Dopplungen auftauchen.
    Das nennt man Debugging und ist die Muttermilch des Programmierers.

    Auf den ersten Blick fällt mir auf, dass diese Zeile
    ​WB.Worksheets("Tabelle1").Range("E12:G12" & Sheets("Tabelle1").Cells(Rows.Count, 2).End(xlUp).Row).Copy
    vermutlich nicht das ist, was du willst.
    Ich glaube nicht, dass du von E12 bis G1212 kopieren willst.

    Marco123 schrieb:

    Konntest Du den im Code irgendwelche garvierenden Schnitzer erkennen?
    Willst du wirklich, dass ich den auseinander nehme?
    Ich will dich eigentlich nicht frustrieren.
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

    Moin,

    petaod schrieb:


    Auf den ersten Blick fällt mir auf, dass diese Zeile
    WB.Worksheets("Tabelle1").Range("E12:G12" & Sheets("Tabelle1").Cells(Rows.Count, 2).End(xlUp).Row).Copy
    vermutlich nicht das ist, was du willst.
    Ich glaube nicht, dass du von E12 bis G1212 kopieren willst.

    Mit dem Part möchte ich eigentlich den Bereich E12:G12 bis zur letzten gefüllten Zeile auswählen.
    Was verursacht denn die Auswahl bis G1212?


    petaod schrieb:


    Marco123 schrieb:

    Konntest Du den im Code irgendwelche garvierenden Schnitzer erkennen?
    Willst du wirklich, dass ich den auseinander nehme?
    Ich will dich eigentlich nicht frustrieren.

    Solange Du dabei nicht meine Mutter beleidigst ist alle ok :D
    Da ich keinen klassischen Progammierer-Hintergrund habe und meine bisherige VBA-Projekte im Try&Error-Verfahren und Hilfe des allmächtigen Internet fabriziert habe, hilft es mir sogar sehr wenn mich jemand mit konstruktiver Kritik wieder auf den rechten Pfad bringt. Das Feedback von erfahreneren Anwendern nehm ich daher immer dankend an.

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „Marco123“ ()

    Marco123 schrieb:

    Was verursacht denn die Auswahl bis G1212

    Marco123 schrieb:

    Range("E12:G12" & Sheets("Tabelle1").Cells(Rows.Count, 2).End(xlUp).Row)
    Hier hängst du an den String "E12:G12"noch die letzte gefüllte Row der Tabelle an.
    Der zweite Teil muss raus.
    WB.Worksheets("Tabelle1").Range("E12:G12").Copy

    Konstruktive Kritik:

    Marco123 schrieb:

    With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
    End With
    Wenn während dem Ablauf der Sub ein Fehler passiert, bleibt Excel in diesem Status hängen und ist nicht mehr ansprechbar.
    So etwas darf nur verwendet werden, wenn eine richtige Fehlerbehandlung da ist.
    On Error Resume Next greift da nur für den ersten Fehler. Bei einem Fehler im zweiten Schleifendurchlauf geht das schief.

    Visual Basic-Quellcode

    1. 'Bildschirmaktualisierung ausschalten
    2. On Error Goto Done
    3. With Application
    4. .ScreenUpdating = False
    5. .Calculation = xlCalculationManual
    6. .EnableEvents = False
    7. End With
    8. ' ...
    9. Done:
    10. If Err.Number <> 0 Then Debug.Print Err.Description 'hier eventuell Fehlerbehandlung einbauen, wenn von Interesse
    11. 'Bildschirmaktualisierung einschalten
    12. With Application
    13. .ScreenUpdating = True
    14. .Calculation = xlCalculationAutomatic
    15. .EnableEvents = True
    16. End With


    Marco123 schrieb:

    'Schleife über alle Dateien im Ordner laufen lassen
    For Each Datei In Ordner.Files
    Select Case LCase(FSO.GetExtensionName(Datei))
    'Format welches gesucht werden soll
    Case "xlsm"
    'Alle Excel-Dateien in eine Collection.Die anderen ignorieren.
    Col.Add Datei
    End Select
    Next
    würde ich etwas kürzer schreiben

    Visual Basic-Quellcode

    1. For Each Datei In Ordner.Files
    2. If LCase(FSO.GetExtensionName(Datei)) = "xlsm" Then Col.Add Datei
    3. Next

    Marco123 schrieb:

    '=========================================

    'Bereich 1 auswählen
    WB.Worksheets("Tabelle1").Range("E12:G12" & Sheets("Tabelle1").Cells(Rows.Count, 2).End(xlUp).Row).Copy

    'Ablage 1 in Ziel
    ThisWorkbook.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 'AndNumberFormats

    'Zwischenspeicher leeren
    Application.CutCopyMode = False

    '=========================================
    ist gefährlich über den Pastebuffer, falls der Benutzer während des Programmablaufs interagiert.

    Visual Basic-Quellcode

    1. Dim Source As Range, Destination As Range
    2. Set Source = WB.Worksheets("Tabelle1").Range("E12:G12")
    3. Set Destination = ThisWorkbook.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1,3)
    4. Destination.Value = Source.Value

    Die zweite Zeile geht auch noch dynamischer, falls der Source-Range sich mal variabel ändert:

    Visual Basic-Quellcode

    1. ThisWorkbook.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(Source.Rows.Count, Source.Columns.Count)

    Ich hoffe, ich habe jetzt keinen Bug eingebaut, ist nur aus dem Kopf und nicht getestet.
    Ansonsten einfach nochmals nachhaken.

    Am Rest habe ich erst mal nichts auszusetzen. ;)


    Edit:
    Ich fand doch noch was:

    Marco123 schrieb:

    Dim FSO
    Dim Datei
    Dim Ordner
    Dim Element
    würde ich sauber als Object deklarieren.
    Wenn du keinen Datentyp angibst, werden die Variant definiert.

    Visual Basic-Quellcode

    1. Dim FSO As Object, Datei As Object, Ordner As Object, Element As Object

    und am Kopf der Datei fehlt mir

    Visual Basic-Quellcode

    1. Option Explicit


    Damit wäre mein Code-Vorschlag:
    Spoiler anzeigen

    Visual Basic-Quellcode

    1. ​Option Explicit
    2. Const Pfad = "C:\Users\ABC\Desktop\Projekt\" 'Pfad der einzulesenden Dateien
    3. Sub Daten_auslesen()
    4. Dim FSO As Object, Datei As Object, Ordner As Object, Element As Variant
    5. Dim Source As Range, Destination As Range, WB As Workbook, Col As New Collection
    6. On Error GoTo Done
    7. Set FSO = CreateObject("Scripting.Filesystemobject")
    8. Set Ordner = FSO.GetFolder(Pfad)
    9. 'Bildschirmaktualisierung ausschalten
    10. Application.ScreenUpdating = False
    11. Application.Calculation = xlCalculationManual
    12. 'Tabellen leeren
    13. Tabelle1.Columns("A:E").ClearContents
    14. 'Schleife über alle Dateien im Ordner laufen lassen
    15. For Each Datei In Ordner.Files
    16. If LCase(FSO.GetExtensionName(Datei)) = "xlsm" Then Col.Add Datei
    17. Next
    18. 'Schleife für Datenübernahme
    19. For Each Element In Col
    20. 'Quelle bestimmen / öffnen
    21. Set WB = Workbooks.Open(Element.Path, ReadOnly:=True)
    22. Set Source = WB.Worksheets("Tabelle1").Range("E12:G12")
    23. Set Destination = Tabelle1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(Source.Rows.Count, Source.Columns.Count)
    24. Destination.Value = Source.Value
    25. 'Quelle schließen ohne zu speichern
    26. WB.Close SaveChanges:=False
    27. Next
    28. Done:
    29. 'Bildschirmaktualisierung einschalten
    30. Application.ScreenUpdating = True
    31. Application.Calculation = xlCalculationAutomatic
    32. End Sub
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

    Dieser Beitrag wurde bereits 3 mal editiert, zuletzt von „petaod“ ()

    petaod schrieb:


    Am Rest habe ich erst mal nichts auszusetzen. ;)


    Du meinst also die erste und letzte Zeile war ok :thumbsup:

    Ich geb zu, damit hab ich nicht gerechnet.
    Da muss ich dann wohl noch so einiges aufräumen (auch in anderen Projekten).

    Besten Dank für Deine Hilfe und für den Code
    Momentan bin ich noch in anderen Themen verhaftet, daher hab ich ihn noch nicht testen können.
    Ich versuchs morgen irgendwie dazuwischen zu schieben.

    Feedback folgt

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „Marco123“ ()

Facebook
Telefonspende