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
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77 |
|
Sub GetData()
Dim sDateiPfad As String, i As Integer
Set oMe = ThisWorkbook.ActiveSheet ' ZielDatei/-Tabelle (= die aktuelle Tabelle der aktuellen _
Datei)
sZelle1 = "B5" ' NOx 1. Temp.
sZelle2 = "B4" ' NOx 1. K-Wert.
sZelle3 = "C5" ' NOx 2. Temp.
sZelle4 = "C4" ' Nox 2. K-Wert.
sZelle5 = "D5" ' SOx 1. Temp.
sZelle6 = "D4" ' SOx 1. ETA
sZelle7 = "E5" ' SOx 2. Temp.
sZelle8 = "E4" ' SOx 2. ETA
sZelle9 = "F4" ' Porenvolumen.
sZelle10 = "G4" ' Abrieb
sZelle11 = "H4" ' BET
sZelle12 = "I4" ' Druckprüfung long.
sZelle13 = "J4" ' Druckprüfung trans.
sZelle14 = "K4" ' Vanadium ist
sZelle15 = "G2" ' Vanadium soll
sZelle16 = "A1" ' Auftragsnummer+Name
sZelle17 = "K1" ' Jahr
iZeile = 2 ' ab Zeile 2 in Zieltabelle eintragen
iSpalte = 1 ' ab Spalte A in Zieltabelle eintragen
Set oFS = CreateObject("Scripting.FileSystemObject")
sDateiPfad = "T:\20_Laboratory\TR\01_SK\01_P\Aufträge\" ' Pfad für zu _
durchsuchende Excel-Dateien; mit Backslash am Ende
For i = 0 To 1
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
sWbName = oDatei.Name
If Left(LCase(oFS.GetExtensionName(sWbName)), 3) = "xls" Then
Workbooks.Open (sDateiPfad & sWbName)
Set WSh = Workbooks(sWbName).Sheets("Übersicht")
With oMe.Cells(iZeile, iSpalte)
.Offset(0, 0).Value = WSh.Range(sZelle1).Value
.Offset(0, 1).Value = WSh.Range(sZelle2).Value
.Offset(0, 2).Value = WSh.Range(sZelle3).Value
.Offset(0, 3).Value = WSh.Range(sZelle4).Value
.Offset(0, 4).Value = WSh.Range(sZelle5).Value
.Offset(0, 5).Value = WSh.Range(sZelle6).Value
.Offset(0, 6).Value = WSh.Range(sZelle7).Value
.Offset(0, 7).Value = WSh.Range(sZelle8).Value
.Offset(0, 8).Value = WSh.Range(sZelle9).Value
.Offset(0, 9).Value = WSh.Range(sZelle10).Value
.Offset(0, 10).Value = WSh.Range(sZelle11).Value
.Offset(0, 11).Value = WSh.Range(sZelle12).Value
.Offset(0, 12).Value = WSh.Range(sZelle13).Value
.Offset(0, 13).Value = WSh.Range(sZelle14).Value
.Offset(0, 14).Value = WSh.Range(sZelle15).Value
.Offset(0, 15).Value = WSh.Range(sZelle16).Value
.Offset(0, 16).Value = WSh.Range(sZelle17).Value
oMe.Hyperlinks.Add Anchor:=oMe.Cells(iZeile, iSpalte + 17), Address:=sDateiPfad _
& sWbName, TextToDisplay:="zum Auftrag"
End With
Workbooks(sWbName).Saved = True
Workbooks(sWbName).Close
iZeile = iZeile + 1
End If
Next
sDateiPfad = "T:\20_Laboratory\TR\01_SK\01_P\Aufträge_1\" ' Pfad für zu _
durchsuchende Excel-Dateien; mit Backslash am Ende
Next i
End Sub
|