01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37 |
|
Sub GetData()
Dim oMe As Worksheet, iZeile As Long, oDatei As Object
Dim oFS As Object, wbQuelle As Workbook, sBlatt As String
Set oMe = ThisWorkbook.ActiveSheet
Const sDateiPfad As String = " \" ' Pfad anpassen
iZeile = 19
Application.ScreenUpdating = False
Set oFS = CreateObject("Scripting.FileSystemObject")
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
If InStrRev(oDatei.Name, "xlsx") Then
sBlatt = "DeinBlattname"
oMe.Cells(iZeile, 2) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("B5"))
oMe.Cells(iZeile, 2) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("B13"))
iZeile = iZeile + 1
End If
Next
Set oMe = Nothing: Set wbQuelle = Nothing
End Sub
Private Function GetValue(ByVal sPath As String, ByVal sFile As String, _
ByVal sSheet As String, oTarget As Object) As Variant
' Einen Wert aus einer Datei holen
On Error GoTo ErrorHandler
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
GetValue = ExecuteExcel4Macro("'" & sPath & "[" & sFile & "]" & sSheet & "'!" _
& oTarget.Range("A1").Address(, , xlR1C1))
Exit Function
ErrorHandler:
GetValue = CVErr(xlErrRef)
End Function
|