Sub GetData()
Dim oMe As Object
Set oMe = Workbooks("alle.xls").Worksheets("Tabelle1")
Const sDateiPfad As String = "C:\Documents and Settings\z563164\Desktop\actualwork\test\test1\"
Const iSbAnzahl = 3
Dim sSuchbegriff(iSbAnzahl) As String
sSuchbegriff(1) = "Supplier:"
sSuchbegriff(2) = "Name:"
sSuchbegriff(3) = "Parts No.:"
Dim i As Integer
Dim sWbName As String
Dim rFound As Range
Dim vWert As Variant
Dim iZeile As Integer
iZeile = 2
Dim oFS As Object, oDatei As Object
Set oFS = CreateObject("Scripting.FileSystemObject")
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
sWbName = oDatei.Name
Workbooks.Open (sDateiPfad & sWbName)
For i = 1 To iSbAnzahl
Set rFound = Workbooks(sWbName).Worksheets(1).Range("a1:z100").Find(sSuchbegriff(i), LookIn:=xlValues)
If Not rFound Is Nothing Then
vWert = Cells(rFound.Row, rFound.Column + 2).Value
oMe.Cells(iZeile, i).Value = vWert
End If
Next
Workbooks(sWbName).Saved = True
Workbooks(sWbName).Close
iZeile = iZeile + 1
Next
End Sub