Brauche Unterstützung

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

  fs.NewSearch: fs.LookIn = sSuchpfad: fs.Filename = sExtension

  fs.NewSearch
  fs.LookIn = sSuchpfad
  fs.Filename = sExtension
  fs.FileType = msoFileTypeAllFiles