Option Explicit
Sub searchncopy()
Dim fs_source As Variant
Dim fs_source_nameonly As Collection
Dim tempstr As String
Dim k As Integer
Dim i As Integer
Dim j As Integer
Dim counter As Integer
Dim foundfile As Boolean
Set fs_source = Application.FileSearch
With fs_source
.LookIn = Cells(2, 4).Value
.SearchSubFolders = True
.FileType = msoFileTypeAllFiles
.Filename = "*"
.Execute
Set fs_source_nameonly = New Collection
For i = 1 To fs_source.FoundFiles.Count
fs_source_nameonly.Add GetFilePart(.FoundFiles(i))
Next i
End With
i = 1
j = 1
While Not IsEmpty(Cells(i, 1).Value)
counter = 0
foundfile = False
For k = 1 To fs_source_nameonly.Count
If StrEqual(fs_source_nameonly(k), Cells(i, 1).Value) Then
foundfile = True
If counter = 0 Then
FileCopy fs_source.FoundFiles(k), Cells(1, 4).Value & fs_source_nameonly(k)
counter = counter + 1
Else
FileCopy fs_source.FoundFiles(k), Cells(1, 4).Value & Left(fs_source_nameonly(k), Len(fs_source_nameonly(k)) - 4) & "(" & counter & ")" & Right(fs_source_nameonly(k), 4)
counter = counter + 1
End If
Else
'nix
End If
Next k
If Not foundfile Then
Cells(j, 6).Value = Cells(i, 1).Value
j = j + 1
End If
i = i + 1
Wend
End Sub
Public Function GetFilePart(file As String) As String
Dim i As Long
For i = Len(file) To 1 Step -1
If Mid(file, i, 1) = "\" Then
GetFilePart = Right(file, Len(file) - i)
Exit Function
End If
Next
End Function
Public Function GetPfadPart(file As String) As String
Dim i As Long
For i = Len(file) To 1 Step -1
If Mid(file, i, 1) = "\" Then
GetPfadPart = Left(file, i)
Exit Function
End If
Next
End Function
Public Function StrEqual( _
ByRef s1 As String, ByRef s2 As String, _
Optional ByVal Compare As VbCompareMethod = vbBinaryCompare _
) As Boolean
If LenB(s1) = LenB(s2) Then
If Compare = vbBinaryCompare Then
If LenB(s1) Then
StrEqual = InStrB(1, s1, s2)
Else
StrEqual = True
End If
Else
StrEqual = StrComp(s1, s2, Compare) = 0
End If
End If
End Function
naja hoffentlich...
