Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

PPT verschieben falls Artikel nicht in Datei

PPT verschieben falls Artikel nicht in Datei
hp
Hallo Leute,
habe in Spalte "B" tägliche neue Artikelnummern Bsp.: 0030014711 oder 051231.
In Ordner "\\vaders10\et2\servicegrad\shortfall psps" liegen .ppt Dateien, die als Namen auch eine Artikelnummer haben Bsp.: 0030014711.ppt
Wenn die Artkelnummer der ppt Datei nicht in Spalte "B" vorkommt soll die ppt Datei in den Ordner
"\\vaders10\et2\servicegrad\shortfall psps\archiv" verschoben werden.
Der Dateiname soll sich dabei um das aktuelle Datum erweitern Bsp.: 0030014711 - 2009-07-14.ppt
Schon mal 1000 Dank für eure Hilfe.
Gruß/hp
AW: PPT verschieben falls Artikel nicht in Datei
14.07.2009 15:55:07
Lothar
Hi,
wo ist die Schnittmenge mit Excel?
In einem Office-Forum bist du besser aufgehoben.
mfg Lothar
AW: PPT verschieben falls Artikel nicht in Datei
14.07.2009 16:01:13
hp
Hallo Lothar,
das Programm soll in ein bestehendes Excel VBA Modul integriert werden, mit welchem anschliessend die noch verbleibenden Dateien im Ursprungsordner mit der täglichen Excelliste verlinkt werden.
Danke und Gruß/hp
AW: PPT verschieben falls Artikel nicht in Datei
15.07.2009 17:06:34
EffHa
Hallo Lothar,
dies in ein Modul kopieren, die Pfade ändern und los gehts.
Die Dateien werden in ein Array eingelesen.
Dann wird die Tabelle mit den Artikelnummern abgegrast und wenn gefunden kopiert, dann gelöscht
Gruß
Fritz
Option Explicit
Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" ( _
ByVal lpFileName As String) As Long
Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" ( _
ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Const MAX_PATH = 260
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
'
'Public Type SYSTEMTIME
' wYear As Integer
' wMonth As Integer
' wDayOfWeek As Integer
' wDay As Integer
' wHour As Integer
' wMinute As Integer
' wSecond As Integer
' wMilliseconds As Integer
'End Type
Public Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Sub test()
Dim I&, J&, Result&, LetzteZeile&
Dim PPtFiles() As String
Dim PfadName$, Suchmuster$
PfadName = "C:\Temp\"
Suchmuster = "*.ppt"
LetzteZeile = GetLastRow(ActiveSheet, "A") 'setzt voraus, das in Spalte "A" was steht
If SearchFilesInList(PfadName, Suchmuster, PPtFiles) Then
For I = 1 To LetzteZeile
For J = 0 To UBound(PPtFiles) - 1
If InStr(1, PPtFiles(J), Cells(I, 3)) Then '3= Spalte mit den Artikelnummern(C)
Result = CopyFile(PfadName & PPtFiles(J), "c:\neuerordner\" & Format(Date, "yyyymmdd" & PPtFiles(J)), 0)
' Die "0" in copyfile bewirkt, dass vorhandene Dateien überschrieben werden
If Result = 0 Then
MsgBox ("Fehler beim kopieren")
Else
Result = DeleteFile(PfadName & PPtFiles(I))
'Wenn Result = dann erfolgreich
End If
End If
Exit For
Next
Next
End If
End Sub
Public Function SearchFilesInList(Pathname$, Pattern$, FoundFileNames) As Boolean
Dim hFind&, hFile&, nFile&              'SDir$,
Dim FD As WIN32_FIND_DATA
ReDim FoundFileNames(0)
If Right(Pathname, 1)  "\" Then Pathname = Pathname & "\"
hFile = FindFirstFile(Pathname & Pattern, FD)
If hFile > 0 Then
SearchFilesInList = True
FoundFileNames(UBound(FoundFileNames)) = ClearFileName(FD.cFileName)
ReDim Preserve FoundFileNames(UBound(FoundFileNames) + 1)
Do
nFile = FindNextFile(hFile, FD)
If nFile > 0 Then
FoundFileNames(UBound(FoundFileNames)) = ClearFileName(FD.cFileName)
ReDim Preserve FoundFileNames(UBound(FoundFileNames) + 1)
End If
Loop While nFile  0
Else
SearchFilesInList = False
'MsgBox ("Keine Dateien für " & fKunde & " gefunden!")
'End
End If
FindClose hFile
End Function

Function ClearFileName(CDat)
Dim X&
X = InStr(1, CDat, Chr$(0))
If X > 0 Then
ClearFileName = Trim$(Left$(CDat, X - 1))
Exit Function
End If
ClearFileName = ""
End Function
Function GetLastRow(Ws As Worksheet, Spalte$) As Long
Spalte = UCase(Spalte & "65536")
GetLastRow = Ws.Range(Spalte).End(xlUp).Row
End Function
Anzeige
AW: PPT verschieben falls Artikel nicht in Datei
14.07.2009 16:24:53
Harry
Hallo,
habe jetzt deinen Beitrag 3 mal gelsen. Wie lautet nun eigentlich deine Frage?
Grüße Harry
AW: PPT verschieben falls Artikel nicht in Datei
14.07.2009 17:57:34
hp
Hi,
PPT Dateien eines Ordners haben alle eine Artikelnummer als "Dateiname".PPT. Alle Dateien des PPT-Ordners sollen verschoben werden, wenn die Artikelnummern nicht mehr in der Excelliste vorkommen.
Gleichzeitig soll der Dateiname der ppt Datei bei diesem Vorgang um das Tagesdatum erweitert werden.
Also:
PPT-Datei vorhanden und Artikelnummer in Exceldatei: keine Aktion
PPT-Datei vorhanden aber Artikelnummer nicht in Exceldatei: Dann Verschieben der PPT ins Archiv + Änderung Dateiname
Hoffe jetzt ist es klarer...
Danke für eure Unterstützung.
Anzeige
AW: PPT verschieben falls Artikel nicht in Datei
15.07.2009 17:12:11
EffHa
Hallo Lothar,
dies in ein Modul kopieren, die Pfade ändern und los gehts.
Die Dateien werden in ein Array eingelesen.
Dann wird die Tabelle mit den Artikelnummern abgegrast und wenn gefunden kopiert, dann gelöscht
Gruß
Fritz
Option Explicit
Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" ( _
ByVal lpFileName As String) As Long
Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" ( _
ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Const MAX_PATH = 260
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
'
'Public Type SYSTEMTIME
' wYear As Integer
' wMonth As Integer
' wDayOfWeek As Integer
' wDay As Integer
' wHour As Integer
' wMinute As Integer
' wSecond As Integer
' wMilliseconds As Integer
'End Type
Public Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Sub test()
Dim I&, J&, Result&, LetzteZeile&
Dim PPtFiles() As String
Dim PfadName$, Suchmuster$
PfadName = "C:\Temp\"
Suchmuster = "*.ppt"
LetzteZeile = GetLastRow(ActiveSheet, "A") 'setzt voraus, das in Spalte "A" was steht
If SearchFilesInList(PfadName, Suchmuster, PPtFiles) Then
For I = 1 To LetzteZeile
For J = 0 To UBound(PPtFiles) - 1
If InStr(1, PPtFiles(J), Cells(I, 3)) Then '3= Spalte mit den Artikelnummern(C)
Result = CopyFile(PfadName & PPtFiles(J), "c:\neuerordner\" & Format(Date, "yyyymmdd" & PPtFiles(J)), 0)
' Die "0" in copyfile bewirkt, dass vorhandene Dateien überschrieben werden
If Result = 0 Then
MsgBox ("Fehler beim kopieren")
Else
Result = DeleteFile(PfadName & PPtFiles(I))
'Wenn Result = dann erfolgreich
End If
End If
Exit For
Next
Next
End If
End Sub
Public Function SearchFilesInList(Pathname$, Pattern$, FoundFileNames) As Boolean
Dim hFind&, hFile&, nFile&              'SDir$,
Dim FD As WIN32_FIND_DATA
ReDim FoundFileNames(0)
If Right(Pathname, 1)  "\" Then Pathname = Pathname & "\"
hFile = FindFirstFile(Pathname & Pattern, FD)
If hFile > 0 Then
SearchFilesInList = True
FoundFileNames(UBound(FoundFileNames)) = ClearFileName(FD.cFileName)
ReDim Preserve FoundFileNames(UBound(FoundFileNames) + 1)
Do
nFile = FindNextFile(hFile, FD)
If nFile > 0 Then
FoundFileNames(UBound(FoundFileNames)) = ClearFileName(FD.cFileName)
ReDim Preserve FoundFileNames(UBound(FoundFileNames) + 1)
End If
Loop While nFile  0
Else
SearchFilesInList = False
'MsgBox ("Keine Dateien für " & fKunde & " gefunden!")
'End
End If
FindClose hFile
End Function
Function ClearFileName(CDat)
Dim X&
X = InStr(1, CDat, Chr$(0))
If X > 0 Then
ClearFileName = Trim$(Left$(CDat, X - 1))
Exit Function
End If
ClearFileName = ""
End Function
Function GetLastRow(Ws As Worksheet, Spalte$) As Long
Spalte = UCase(Spalte & "65536")
GetLastRow = Ws.Range(Spalte).End(xlUp).Row
End Function
Anzeige
AW: PPT verschieben falls Artikel nicht in Datei
16.07.2009 12:24:37
hp
Hallo Lothar, Hallo Fritz,
Teste gerade den Code (ist ja ein "Wahnsinns-Ding") ! Vielen Dank schon mal für eure Mühe.
Nachdem ich die Pfade im Code angepasst habe, kann ich das Makro ausführen.
Ergebnis:
Das Makro läuft bis zum Ende durch ohne die Verschiebe- und Löschfunktion durchzuführen.
Nach folgender Zeile springt das Programm immer auf "Else/SearchFilesInList = False" obwohl Dateien zur Verarbeitung im Ordner vorhanden sind:
If hFile grösser 0 Then (habe das grösser Zeichen hier durchs Wort ersetzt da ich sonst nicht posten kann)
Ich habe die Pfade mehrmals auf Richtigkeit überprüft.
Könnt ihr mir dazu bitte noch mal einen Tip geben?
Vielen Dank/hp
Anzeige
AW: PPT verschieben falls Artikel nicht in Datei
16.07.2009 13:01:41
EffHa
Sind in dem Array den gefundene Dateiname vorhanden?
Du kannst ja mal nur die Dateinamen ausgeben lassen.
If SearchFilesInList(PfadName, Suchmuster, PPtFiles) Then
For I = 0 To UBound(PPtFiles) - 1
MsgBox (PPtFiles(I))
Next
End If
Hast Du auch bei der Funktion CoopyFile() den Pfad (c:\neuerordner) entsprechend geändert?
Die Spalte der Artikelnummern in der Datei (ich habe hier Spalte "C" genommen) muss auch angepaßt werden. Stehen die Nummern z.B. in Spalte "A" dann muss es heißen:
If InStr(1, PPtFiles(J), Cells(I, 3)) Then
Gruß
Fritz
AW: PPT verschieben falls Artikel nicht in Datei
16.07.2009 13:05:08
EffHa
Hab mich eben vertippt, es muss natürlich Cells(I, 1) heißen
Stehen die Nummern z.B. in Spalte "A" dann muss es heißen:
If InStr(1, PPtFiles(J), Cells(I, 1)) Then
Anzeige
AW: PPT verschieben falls Artikel nicht in Datei
16.07.2009 14:59:26
hp
Hi,
habe die entsprechende Zeile geändert. Jetzt erhalte ich im Befehl:
If hFile grösser 0 Then
auch den Wert (-1) wenn ich den Curser über hFile verweile. Ergebnis ist, dass das Programm immer noch auf Else springt.
Habe testweise kleiner 0 als Bedingung eingegeben. Jetzt führt das Programm auch die Funktion ClearFile name aus, springt dann nach ReDim Reserve
in der Do Schleife hat
nFile den Wert 0 (auch nach nFile = FindNextFile(hFile, FD)
hFile den Wert -1
If nFile grösser 0 Then bewirkt wiederum nur end if ohne dass
FoundFileNames(UBound(FoundFileNames)) = ClearFileName(FD.cFileName)
ReDim Preserve FoundFileNames(UBound(FoundFileNames) + 1)
ausgeführt werden.
Habt Ihr bitte noch eine Idee?
Anzeige
AW: PPT verschieben falls Artikel nicht in Datei
17.07.2009 11:14:27
EffHa
Hallo,
wenn hfile den Wert -1 hat, dann wurden keine ppt-dateien gefunden.
dann kann die Funktion NextFile natürlich auch keine finden
Poste doch den Code, wie Du ihn verwendest.
Am besten gibst Du auch den Ordner mit an, in dem die ppt-Dateien stehen.
Gruß
Fritz
AW: PPT verschieben falls Artikel nicht in Datei
17.07.2009 12:07:42
hp
Hallo Fritz,
ich bin der größte Depp im Forum. Habe einen Fehler in einer der Laufwerksbezeichnungen gefunden. Dabei hatte ich genau dies mehrmals kontrolliert aber den Fehler immer überlesen. Schande über mich!
Jetzt läuft das Makro. Bleibt aber an einer bestimmten Stelle stehen. In der geposteten Datei kannst Du auch sehen, dass scheinbar nur die ppt-Dateien verschoben werden, die eigentlich nicht verschoben werden dürften, da sie noch in der Artikelliste vorkommen.
Gruß/hp
Anzeige
AW: PPT verschieben falls Artikel nicht in Datei
17.07.2009 12:25:49
EffHa
Hallo HP,
habe ich auch falsch gemacht.
Hier der Code, um die Nicht vorhanden zu koieren und löschen.
zu Deinem Verständnis:
Die Boolsche variable IstVorhanden ist neu
Sie wird bei der 1. Schleife immer auf "False" gesetzt.
Wird in der 2. Schleife eine Übereinstimmung festgestellt, wird Sie auf "True" gestzt und die 2. schleife verlassen. Gibt es keine Übereinstimmung in der 2. Schleife, wird diese am Ende verlassen und die Variable "IstVorhanden" hat immer noch den Wert False und die Kopier- und Löschaktion wird angestoßen.
Du musst noch das Wort "grösser" in das "grösser-Zeichen" ändern
Gruß
Fritz
Dim IstVorhanden As Boolean
If SearchFilesInList(PfadName, Suchmuster, PPtFiles) Then
For I = 1 To LetzteZeile
IstVorhanden = False
For J = 0 To UBound(PPtFiles) - 1
If InStr(1, PPtFiles(J), Cells(I, 3)) grösser 0 Then '3= Spalte mit den Artikelnummern(C)
IstVorhanden = True
Exit For
End If
Next
If Not IstVorhanden Then
Result = CopyFile(PfadName & PPtFiles(J), "c:\neuerordner\" & Format(Date, "yyyymmdd" & PPtFiles(J)), 0)
' Die "0" in copyfile bewirkt, dass vorhandene Dateien überschrieben werden
If Result = 0 Then
MsgBox ("Fehler beim kopieren")
Else
Result = DeleteFile(PfadName & PPtFiles(I))
'Wenn Result = dann erfolgreich
End If
End If
Next
End If
Anzeige
AW: PPT verschieben falls Artikel nicht in Datei
17.07.2009 13:59:48
hp
Hallo Fritz,
habe den neuen Code eingegeben. Das Makro läuft komplett durch und findet auch mit istvorhanden die richtigen Einträge und wählt exit for wenn der Artikel in der Datei vorkommt.
So weit ist die Logik jetzt richtig.
leider ergibt aber der Befehl:
Result = CopyFile(PfadName & PPtFiles(J), "\\vaders10\et2\servicegrad\Shortfall_PSPs\Archiv PSPs\" & Format(Date, "yyyymmdd" & PPtFiles(J)), 0)
in allen Fällen: result "0"
Somit werden die Kopie und Löschfunktionen nicht durchgeführt...
Habe dann Testweise im result befehl die zwei "pptFiles(J) durch pptFiles(I) ersetzt.
Jetzt hat das Makro die Dateien gespeichert und gelöscht. Ergebnis ist somit ok
Jezt kommts:
Die Schleife läuft auch nach Abarbeitung aller vorhandenen ppt noch mal in den Befehl: Result = CopyFile... und steht dann dort mit der Meldung: Index ausserhalb des gültigen Bereiches.
Ich glaub´wenn wir das lösen haben wir eine schwere Geburt erfolgreich hinter uns - schade nur dass nur du derjenige ist der die Austreibphase erlebt...
Danke noch mal und Gruß/hp
Anzeige
AW: PPT verschieben falls Artikel nicht in Datei
17.07.2009 15:49:37
EffHa
Hallo HP,
da der Wert Ubound(pptfiles) noch dem löschen einer Datei nicht mehr korrekt ist, habe ich noch ein wenig umgebaut.
Wenn es jetzt noch nicht klappt, muss ich Dich auf Montag vertrösten.
Guckst du hier:
Dim IstVorhanden As Boolean, AnzahlFiles&
If SearchFilesInList(PfadName, Suchmuster, PPtFiles) Then
AnzahlFiles = UBound(PPtFiles) - 1
For I = 1 To LetzteZeile
IstVorhanden = False
For J = 0 To AnzahlFiles
If InStr(1, PPtFiles(J), Cells(I, 3)) > 0 Then '3= Spalte mit den Artikelnummern(C)
IstVorhanden = True
Exit For
End If
Next
If Not IstVorhanden Then
Result = CopyFile(PfadName & PPtFiles(J), "c:\neuerordner\" & Format(Date, "yyyymmdd" & PPtFiles(J)), 0)
' Die "0" in copyfile bewirkt, dass vorhandene Dateien überschrieben werden
If Result = 0 Then
MsgBox ("Fehler beim kopieren")
Else
Result = DeleteFile(PfadName & PPtFiles(I))
If Result <> 0 Then AnzahlFiles = AnzahlFiles - 1
'Wenn Result <> 0 dann erfolgreich
End If
End If
Next
End If
AW: PPT verschieben falls Artikel nicht in Datei
20.07.2009 13:25:44
hp
Hallo Fritz,
Jetzt klappt´s!!! Vielen, vielen Dank für Deine Hilfe. Ich habe in den letzten Tagen mehr über VBA gelernt als in den zwei Jahren vorher.
Falls Du für den Code selbst noch verwendung hast mußt Du im "Result Befehl" die zwei "pptFiles(J) durch pptFiles(I) ersetzen.
Gruß/hp
AW: PPT verschieben falls Artikel nicht in Datei
16.07.2009 13:24:45
hp
Hallo Lothar, Hallo Fritz,
Teste gerade den Code (ist ja ein "Wahnsinns-Ding") ! Vielen Dank schon mal für eure Mühe.
Nachdem ich die Pfade im Code angepasst habe, kann ich das Makro ausführen.
Ergebnis:
Das Makro läuft bis zum Ende durch ohne die Verschiebe- und Löschfunktion durchzuführen.
Nach folgender Zeile springt das Programm immer auf "Else/SearchFilesInList = False" obwohl Dateien zur Verarbeitung im Ordner vorhanden sind:
If hFile grösser 0 Then (habe das grösser Zeichen hier durchs Wort ersetzt da ich sonst nicht posten kann)
Ich habe die Pfade mehrmals auf Richtigkeit überprüft.
Könnt ihr mir dazu bitte noch mal einen Tip geben?
Vielen Dank/hp

302 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige