Tabelle mit Ordner abgleichen

[alex.saleen]

Hallo alle zusammen  :17:
Ich habe mal wieder einen Auftrag bei dem ich etwas festhänge... 
Ich hoffe ihr könnt/wollt mir weiterhelfen!
Ich habe eine Excel Tabelle mit ca. 2700 Artikeln bzw. deren Bezeichnungen. Dazu passend habe ich einen Ordner mit 3200 Artikelbildern also JPG's. Die JPG's haben den selben Namen wie in der Excel Tabelle. Jetzt ist das Problem, dass die 500 Artikel überflüssig sind... Gibt es eine Möglichkeit die Excel Tabelle mit dem Ordner abzugleichen und die übereinstimmenden bzw. die nicht übereinstimmenden Bilder in einen separaten Ordner zu bewegen? Anderenfalls kann ich auch die Bilder in eine weitere Excel Tabelle einfügen, wenn das den Abgleich einfacher macht.
Danke schon mal im Voraus

MfG
Alex

[alex.saleen]

PS: 
Die Bilder müssen nicht unbedingt bewegt werden, die überflüssigen Bilder können auch gelöscht werden oder auf eine andere Weise erkenntlich gemacht werden :)

[Gast 123]

Hallo

das kleine Programm in Excel 2003 listet für jede beliebige Tabelle die man in Zelle B1 angibt alle Objekte im Blatt auf. Mit Angabe in welcher Zelle sich das Objekt befindet (Obere Linke Ecke)  Das Programm kann auch geändert werden um überflüssige Zelle auszuschneiden oder zu löschen.

Mir ist nachträgöich noch eiin Code zum löschen eingefallen, der wirksam wird, wenn man in Spalte D für das entsprechende Objekte den Text "aa" angibt.
Ich kann aber nur heute Rat geben, morgen habe ich leider kein Internet! Bei Fragen müssten bitte die Kollegen weiterhelfen.

mfg Gast 123

Code:

Option Explicit
Dim Sht As Worksheet, Blatt As String
Dim ObjName As String


Sub Objekte_löschen()
Dim Zahl As Long, j As Long
With Worksheets("Liste")
   On Error Resume Next
   Blatt = .Range("B1").Value
   Zahl = Sht.DrawingObjects.Count
   Set Sht = Worksheets(Blatt)
  
   For j = 1 To Zahl
      If .Cells(j + 2, 4) = "aa" Then
         ObjName = .Cells(j + 2, 2)
         Sht.DrawingObjects(ObjName).Delete
   Next j
End With
End Sub

[Fennek]

Hallo,

ich hatte das so verstanden:

Code:

const Bilder as string = "c:\temp\" ' <<<< anpassen >>>>

sub unnoetigeBilder()
'Namen der benötigten Bilder in Spalte A
'Ausgabe der nicht benötugten jpg's in Sheets(2)

dim rng as range
f = dir(Bilder & "*.jpg")
    set rng = columns(1).find(f,, xlvalues, xlpart)
    if rng is nothing then sheets(2).cells(rows.count,1).end(xlup).offset(1) = f
f = dir
loop
end sub

ungeprüft, kann Tippfehler enthalten

mfg

[alex.saleen]

Hallo  
Bei der Lösung mit dem Programm für Excel 2003 bin ich mir leider nicht ganz sicher ob das so funktioniert :/ 
Der Code von Fennek schaut da schon plausibler aus.
Nur leider sagt mir excel, dass bei dem Loop ein Do fehlt :/
Was müsste ich denn da noch nachtragen.

MfG 

Alex

[Fennek]

ungeprüfte Code erfordern entwas Kreativität.

Einen Schritt besser:

Code:

const Bilder as string = "c:\temp\" ' <<<< anpassen >>>>

sub unnoetigeBilder()
'Namen der benötigten Bilder in Spalte A
'Ausgabe der nicht benötugten jpg's in Sheets(2)

dim rng as range

f = dir(Bilder & "*.jpg")
do while f <> vbnullstring
    set rng = columns(1).find(f,, xlvalues, xlpart)
    if rng is nothing then sheets(2).cells(rows.count,1).end(xlup).offset(1) = f
f = dir
loop
end sub

[alex.saleen]

Hallo
Sorry dass ich mich jetzt erst wieder melde. Die letzten zwei Tage war viel los...
Ich hab den Code nochmal ausprobiert und jetzt tut er es tatsächlich. Allerdings passiert nichts (oder ich sehe es zumindest nicht).
Ich hänge hier mal ein Bild der Excel-Datei an.
Vielleicht habe ich da ja was falsch verstanden    

MfG
Alex

[Fennek]

Hallo Alex,

der Code löscht keine Dateien, sondern schreibt die Namen der Dateien, die nach Prüfung im nächsten Schritt gelöscht werden sollen, in Sheets(2).

Soweit im Bild zu erkennen, gibt es in Deinem Workbook kein Sheet(2). Der Code benötigt am Ende des Pfades ein "\", es gibt aber sicher auch andere Fehlermöglichkeiten.

Wie soll man das finden, mit den sehr eingeschränkten Kommunikationsmöglichkeiten eines Forums?

mfg

[schauan]

Hallöchen,

das wäre mal ein Ansatz ohne Sheet Der Code baut sich eine Collection auf, in der nur Files stehen, die es einmal gibt (nur Name ohne Extension). Die Extension lasse ich weg, weil ich nicht weiß, ob zuerst das xls oder das jpg gefunden wird und später ja nur die jpg verschoben werden sollen. Im nächsten Step müsste man die Collection durchgehen und die Dateien anhand der enthaltenen Dateinamen löschen.

Ggf. müsste man noch differenzieren, falls bei den "Einmaligen" welche dabei sein können, die nicht gelöscht werden sollen.
Wenn es verschiedene Bildformate gibt, müsste man entsprechende Varianten vorsehen.

Wenn Du einen Haltepunkt bei End Sub setzt, kannst Du schauen, was in der Collection steht und dann ggf. verschoben würde.

Code:

Sub DirVergleich()
'Variablendeklarationen
Dim colFiles As New Collection
Dim objFSO As Object, objPath As Object
Dim objFiles As Object, objFile As Object
'Objekte instanzieren
'FSO
Set objFSO = CreateObject("scripting.FileSystemObject")
'Dateipfad, anpassen!
Set objPath = objFSO.GetFolder("C:\Test\A")
'Dateien im Pfad
Set objFiles = objPath.Files
'Schleife ueber alle Dateien
For Each objFile In objFiles
  'Bei Fehler weiter
  On Error Resume Next
  'Datei der Collection hinzufuegen, Key fuer indirekte Pruefung auf Eindeutigkeit
  colFiles.Add objFSO.getbaseName(objFile.Path), objFSO.getbaseName(objFile.Path)
  'Bei Fehler (wenn der Key schon vorhanden ist), dann Eintrag loeschen
  If Err Then colFiles.Remove objFSO.getbaseName(objFile.Path)
'Ende Schleife ueber alle Dateien
Next objFile
'Hier kaeme jetzt verschieben
End Sub

[ralf_b]

Hallöchen,

interessantes Thema.  aber die Lösungsvorschläge sind nicht so sehr final. ich habe die Vorschläge mal eine bisschen zusammengefaßt.
die im Bilderordner überzähligen Bilder werden in ein anders Verzeichnis verschoben. du kanns sie auch löschen das muß du nur jeweils auskommentieren oder eben nicht . einzig die Pfade für die Ordner sind noch zu setzen. deine Exceldatei ist hoffentlich nicht im selben Ordner wie die Bilder.

Code:

Sub DirVergleich()
    'Variablendeklarationen
    Dim colFiles As New Collection
    Dim objFSO As Object, objPath As String, objPathT As String
    Dim objFiles As Object, objFile As Object
    Dim i As Long
    'Objekte instanzieren
    'FSO
    Set objFSO = CreateObject("scripting.FileSystemObject")
    'Dateipfad, anpassen!
    objPath = "bilder Pfad anpassen"
    objPathT = "Zielpfad anpassen"
   
    'Dateien im Pfad
    Set objFiles = objPath.Files
   
    ' namen+ pfad  aus tabelle in collection
    For i = 1 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
        colFiles.Add Sheets(1).Cells(i, 1), Sheets(1).Cells(i, 1)
    Next
   
    'vergleich collection mit dateien in ordner und verschieben oder löschen
    For Each objFile In objFiles
    
      If Not Contains(colFiles, objFile.Name) Then
          objFile.Move objPathT & "\" ' achtung pfad muß mit \ enden
          'oder löschen
          'Kill (objFile)
      End If
     
    Next objFile

End Sub


Public Function Contains(col As Collection, item As String) As Boolean

    Dim i As Integer

    For i = 1 To col.Count

        If col.item(i) = item Then
            Contains = True
            Exit Function
        End If

    Next i

    Contains = False

End Function