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
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 :)
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
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
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.
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
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
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?
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
. \\\|/// Hoffe, geholfen zu haben. ( ô ô ) Grüße, André aus G in T ooO-(_)-Ooo (Excel 97-2019+365)
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
