Bereits kopierte Werte nicht erneut kopieren

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Bereits kopierte Werte nicht erneut kopieren
von: longline
Geschrieben am: 11.11.2015 07:48:30

Hallo Experten-Forum,
meine VBA-Kenntnisse sind äusserst bescheiden und mit hohem Recherche-Aufwand verbunden. Nichtsdestotrotz habe ich mir jetzt ein Makro zusammengestellt, das den geforderten Zweck erfüllt:
- Öffne Ausgangsdatendatei
- Finde bestimmte Werte in definierter Spalte ("2015")
- Kopiere komplette Zeile mit gefundenen Werten in Zieldatei
===============================================================


Sub Reporting()
Dim rng As Range
Dim loDeinWert As Long
Dim sFirstAdress As String
Workbooks.Open Filename:=ThisWorkbook.Path & "\FILE1.xlsx"
loDeinWert = 2015
Set rng = Workbooks("FILE1.xlsx").Worksheets("Sheet").Range("C:C").Find(loDeinWert)
If rng Is Nothing Then
  MsgBox "Wert " & loDeinWert & " NONE"
Else
  sfirstaddress = rng.Address
  Do
    rng.EntireRow.Copy
    
Workbooks("Mappe1.xlsm").Worksheets("DATA").Cells(Rows.Count, "A").End(xlUp) 
      .Offset(1, 0).PasteSpecial Paste:=xlPasteAll
    Set rng = Workbooks("FILE1.xlsx").Worksheets("Sheet").Range("C:C").FindNext(rng)
  Loop While Not rng Is Nothing And rng.Address <> sfirstaddress
End If
End Sub

===================================================================
Soweit, so gut (funktioniert), aber: die obige Abfrage bzw. kopierten Zeilen kann pro Datei sehr umfangreich sein (z.B. 3000 Zeilen pro Ausgangsdatei).
Wöchentlich kommt eine weitere Ausgangsdatei (File1, File2, File3 etc) hinzu, die mit diesem Makro überprüft- und in Zieldatei kopiert wird.
Kann ich irgendwie verhindern, dass die bereits bearbeitete Ausgangsdatei nochmals abgefragt/kopiert wird ohne dass ich jede Woche etwas am Code ändern muss?
Ursprünglich hatte ich den Gedanken, die vorangegangenen Daten zu überschreiben (Select.ClearContent). Nach einer gewissen Zeit kommen aber immer mehr Dateien/Daten hinzu, so dass die Ausführung des Codes eine ziemliche Zeit in Anspruch nehmen wird. Das möchte ich umgehen, indem wöchentlich nur die "neuen" Daten hinzugefügt werden.
Ich hoffe, es kann mir jemand helfen.
Vielen Dank!

Bild

Betrifft: AW: Bereits kopierte Werte nicht erneut kopieren
von: Tino
Geschrieben am: 11.11.2015 08:27:24
Hallo,
es würde verschiedene Möglichkeiten geben eine Datei nicht zweimal abzufragen.
1. eine Liste in Excel führen die die bereits abgefragten Dateien Listet und diese bei der nächsten Abfrage überspringen.
2. anhand des Erstelldatums der Datei.
Im Excel merken wann die letzte Abfrage war und nur Dateien abfragen die im erstell Datum jünger sind.
Zu 2. in etwa so, habe ich jetzt nicht getestet!

Sub Reporting()
Dim rng As Range
Dim loDeinWert As Long, i&
Dim sFirstAdress As String, sPath$
Dim DateLetzteAbfrage As Date
Dim fso As Object, exWB As Workbook, oFile, ArFile()
DateLetzteAbfrage = _
    Workbooks("Mappe1.xlsm").Worksheets("DATA").Range("A2").Value
sPath = ThisWorkbook.Path
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
Set fso = CreateObject("Scripting.FileSystemObject")
For Each oFile In fso.getfolder(sPath).Files
    If oFile.Name Like "*.xlsx" Then
        If oFile.DateCreated > DateLetzteAbfrage Then
            i = i + 1
            ReDim Preserve ArFile(1 To i)
            ArFile(i) = oFile.Path
        End If
    End If
Next oFile
If i < 1 Then Exit Sub 'keine Datei gefunden
For i = LBound(ArFile) To UBound(ArFile)
    
        Set exWB = Workbooks.Open(Filename:=ArFile(i))
        loDeinWert = 2015
        
        Set rng = exWB.Worksheets("Sheet").Range("C:C").Find(loDeinWert)
        
        If rng Is Nothing Then
            MsgBox "Wert " & loDeinWert & " NONE"
        Else
            sFirstAdress = rng.Address
            Do
                rng.EntireRow.Copy
                Workbooks("Mappe1.xlsm").Worksheets("DATA").Cells(Rows.Count, "A") _
                .End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
                Set rng = exWB.Worksheets("Sheet").Range("C:C").FindNext(rng)
            Loop While Not rng Is Nothing And rng.Address <> sFirstAdress
        End If
Next i
End Sub

Gruß Tino

Bild

Betrifft: AW: Bereits kopierte Werte nicht erneut kopieren
von: longline
Geschrieben am: 11.11.2015 10:34:20
Hi Tino,
erstmal super vielen Dank für deine Hilfe!
Grundsätzlich funktioniert dein Code, allerdings öffnet und übernimmt er bei jeder Abfrage die Daten
aus File1, d.h. die Daten sind mehrfach in Mappe1 vorhanden.
In welcher Relation stehen
If oFile.DateCreated grösser DateLetzteAbfrage Then
i = i + 1
aus deinem Code? Ich habe mehrfach versucht anzupassen, aber File1 wird immer wieder zuerst übernommen und an die alten Daten angefügt.
Viele Grüsse
Markus

Bild

Betrifft: AW: Bereits kopierte Werte nicht erneut kopieren
von: Tino
Geschrieben am: 11.11.2015 18:29:56
Hallo,
ich bin davon ausgegangen das irgendwo ein Datum der letzten Abfrage steht.

DateLetzteAbfrage = _
    Workbooks("Mappe1.xlsm").Worksheets("DATA").Range("A2").Value
Wo das bei dir sein kann, weiß ich nicht!
Kann man aber auch mittels VBA einfügt werden, Zelle muss Du anpassen!
Sub Reporting()
Dim rng As Range
Dim loDeinWert As Long, i&
Dim sFirstAdress As String, sPath$
Dim DateLetzteAbfrage As Date
Dim fso As Object, exWB As Workbook, oFile, ArFile()
Dim rngDate As Range
'Zelle wo Datum der letzten abfrage steht!
Set rngDate = Workbooks("Mappe1.xlsm").Worksheets("DATA").Range("A2").Value
DateLetzteAbfrage = rngDate.Value
sPath = ThisWorkbook.Path
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
Set fso = CreateObject("Scripting.FileSystemObject")
For Each oFile In fso.getfolder(sPath).Files
    If oFile.Name Like "*.xlsx" Then
        If oFile.DateCreated > DateLetzteAbfrage Then
            i = i + 1
            ReDim Preserve ArFile(1 To i)
            ArFile(i) = oFile.Path
        End If
    End If
Next oFile
If i < 1 Then Exit Sub 'keine Datei gefunden
For i = LBound(ArFile) To UBound(ArFile)
    
        Set exWB = Workbooks.Open(Filename:=ArFile(i))
        loDeinWert = 2015
        
        Set rng = exWB.Worksheets("Sheet").Range("C:C").Find(loDeinWert)
        
        If rng Is Nothing Then
            MsgBox "Wert " & loDeinWert & " NONE"
        Else
            sFirstAdress = rng.Address
            Do
                rng.EntireRow.Copy
                Workbooks("Mappe1.xlsm").Worksheets("DATA").Cells(Rows.Count, "A") _
                .End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
                Set rng = exWB.Worksheets("Sheet").Range("C:C").FindNext(rng)
            Loop While Not rng Is Nothing And rng.Address <> sFirstAdress
        End If
Next i
rngDate.Value = Now 'Now = aktuelles Datum + Uhrzeit, Date = aktuelles Datum
End Sub
Gruß Tino

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Bereits kopierte Werte nicht erneut kopieren"