AW: komplizierte Dateiverknüpfungen
22.08.2009 19:14:52
Josef
Hallo Bernd,
probier mal so, allerdings wird der Jahreswechsel nicht berücksichtigt!
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub GetValuesFromFile()
Dim objFiles() As Object, lngResult As Long
Dim strRoot As String, strFile As String, strTab As String
Dim strPath As String, strSource As String
strRoot = "C:\2009\" 'Stamm-Pfad
strFile = "test.xls" 'Dateiname
strTab = "Analyse" 'Tabellenname
If Right(strRoot, 1) <> "\" Then strRoot = strRoot & "\"
lngResult = FileSearchINFO(objFiles, strRoot, strFile, True)
If lngResult >= 9 Then
strPath = objFiles(UBound(objFiles) - 9).ParentFolder
strSource = "'" & strPath & "\[" & strFile & "]" & strTab & "'!"
Range("D2:D" & Cells(Rows.Count, 1).End(xlUp).Row).Formula = "=INDEX(" & strSource & "B:B,MATCH(A2," & strSource & "A:A,0))"
Range("E2:E" & Cells(Rows.Count, 1).End(xlUp).Row).Formula = "=INDEX(" & strSource & "C:C,MATCH(A2," & strSource & "A:A,0))"
Range("D2:E" & Cells(Rows.Count, 1).End(xlUp).Row) = Range("D2:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value
Else
Range("D2:D" & Cells(Rows.Count, 1).End(xlUp).Row) = "Datei nicht gefunden"
Range("E2:E" & Cells(Rows.Count, 1).End(xlUp).Row) = "Datei nicht gefunden"
End If
End Sub
'by J.Ehrensberger
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)
Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant
Set fobjFSO = CreateObject("Scripting.FileSystemObject")
Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
On Error GoTo ErrExit
If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
Redim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
Redim Preserve Files(UBound(Files) + 1)
Else
Redim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function
Gruß Sepp