- #21
M
Matjes
Bekanntes Mitglied
- Dabei seit
- 22.08.2001
- Beiträge
- 2.308
- Reaktionspunkte
- 0
Versuch mal diese Version mit Pfadprüfung:
Gruß Matjes
Gruß Matjes
Code:
Option Explicit
Const c_Quellpfad = e:\daten2003
Const c_Zielpfad_pos = e:\positiv
Const c_Zielpfad_neg = e:\negativ
Type f_DateiAngabePfad_type
Datei As String
Pfad As String
Pfad_Datei As String
End Type
Type f_Datei_type
start As Long
cnt As Long
f() As f_DateiAngabePfad_type
End Type
Public f_feld(1 To 1) As f_Datei_type
'**********************************************************************************
Sub DateienTrennen()
->liest alle Datei-Namen des Quellverzeichnisses ein
->prüft, ob sich darunter Quadrupel von Dateinamen befinden,
->die sich nur durch das erste Zeichen unterscheiden
->wenn ja: -> werden diese Dateien in das Positiv-Verzeichnis kopiert
->der Rest wird in das Negativ-Verzechnis kopiert
'**********************************************************************************
Dim ws As Worksheet, i As Long, l_rows As Long, l_cols As Long
->Pfad- und Laufwerks-Angaben prüfen
If Not (PfadAngabePruefen(c_Quellpfad) And _
PfadAngabePruefen(c_Zielpfad_pos) And _
PfadAngabePruefen(c_Zielpfad_neg)) Then
Exit Sub
End If
->files aus Quellverzeichnis lesen
If 0 < FileVerz_Anlegen(c_Quellpfad, *;*.*, f_feld) Then
->neues Blatt anlegen
Set ws = ActiveWorkbook.Worksheets.Add
->Spalte 1 + 2 als Text formatieren
ws.Columns(1).NumberFormat = @
ws.Columns(2).NumberFormat = @
For i = f_feld(1).start To f_feld(1).cnt
ws.Cells(i, 1).Value = f_feld(1).f(i).Datei
ws.Cells(i, 2).Value = _
Right(ws.Cells(i, 1).Value, Len(ws.Cells(i, 1).Value) - 1)
Next
->nach Spalte 2 sortieren
l_rows = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
l_cols = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
->Daten nach Spalte 2 sortieren
ws.Range(ws.Cells(1, 1), ws.Cells(l_rows, l_cols)).Sort _
Key1:=ws.Range(ws.Cells(1, 2), ws.Cells(1, 2)), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
->für jedes file
For i = 1 To l_rows
If (ws.Cells(i, 2).Value = ws.Cells(i + 1, 2).Value) And _
(ws.Cells(i, 2).Value = ws.Cells(i + 2, 2).Value) And _
(ws.Cells(i, 2).Value = ws.Cells(i + 3, 2).Value) Then
->positiv -> alle 4 kopieren
FileCopy c_Quellpfad & \ & ws.Cells(i, 1).Value, _
c_Zielpfad_pos & \ & ws.Cells(i, 1).Value
FileCopy c_Quellpfad & \ & ws.Cells(i + 1, 1).Value, _
c_Zielpfad_pos & \ & ws.Cells(i + 1, 1).Value
FileCopy c_Quellpfad & \ & ws.Cells(i + 2, 1).Value, _
c_Zielpfad_pos & \ & ws.Cells(i + 2, 1).Value
FileCopy c_Quellpfad & \ & ws.Cells(i + 3, 1).Value, _
c_Zielpfad_pos & \ & ws.Cells(i + 3, 1).Value
i = i + 3
Else
->negativ -> einzelnes file kopieren
FileCopy (c_Quellpfad & \ & ws.Cells(i, 1).Value), _
c_Zielpfad_neg & \ & ws.Cells(i, 1).Value
End If
Next
->Blatt wieder löschen
Application.DisplayAlerts = False: ws.Delete: Application.DisplayAlerts = True
Set ws = Nothing
End If
End Sub
'**********************************************************************************
Public Function FileVerz_Anlegen(ByRef sSuchpfad As String, ByRef sExtension As String, _
ByRef fx() As f_Datei_type) As Integer
'**********************************************************************************
'FilesVerzeichnis eines Directories erstellen
Dim fs As FileSearch, i As Long, ret As Integer
->Rueckgabewert Anzahl files initialisieren
FileVerz_Anlegen = 0
->Verz initialisieren
fx(1).cnt = 0: fx(1).start = 1
->Verz erstellen
Set fs = Application.FileSearch
fs.NewSearch: fs.LookIn = sSuchpfad: fs.Filename = sExtension
i = fs.Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending)
If fs.FoundFiles.Count > 0 Then
For i = 1 To fs.FoundFiles.Count
fx(1).cnt = fx(1).cnt + 1
ReDim Preserve fx(1).f(fx(1).start To fx(1).cnt)
fx(1).f(fx(1).cnt).Pfad_Datei = fs.FoundFiles(i)
fx(1).f(fx(1).cnt).Pfad = sSuchpfad
fx(1).f(fx(1).cnt).Datei = NurFilenamen(fs.FoundFiles(i))
FileVerz_Anlegen = FileVerz_Anlegen + 1
Next i
Else
MsgBox No file found: & sSuchpfad & \ & sExtension
End If
Set fs = Nothing
End Function
'**********************************************************************************
Private Function NurFilenamen(s_vollstaendigerFilename As String) As String
'**********************************************************************************
'schneidet die Pfadangaben aus einem String und gibt den Filenamen zurueck
Dim p1 As Integer, p2 As Integer
p2 = 0: p1 = 0
Do
p1 = InStr(p1 + 1, s_vollstaendigerFilename, \): If p1 <> 0 Then p2 = p1
Loop While p1 <> 0
NurFilenamen = Right(s_vollstaendigerFilename, Len(s_vollstaendigerFilename) - p2)
End Function
'**********************************************************************************
Private Function PfadAngabePruefen(s As String) As Boolean
Dim olddir_s As String
On Error GoTo Fehlerbearbeitung
PfadAngabePruefen = True
olddir_s = CurDir
ChDir (s)
On Error GoTo 0
ChDir (olddir_s)
Exit Function
Fehlerbearbeitung:
PfadAngabePruefen = False
MsgBox (Laufwerk oder Pfad nicht vorhanden: & vbLf & s)
End Function