Link in VBA
16.06.2020 07:50:53
Karl
Anbei mein Projekt!
Ich lese Werte aus Excel-Dateien aus. Jetzt hätte ich noch gerne, dass aus der ausgelesenen Zelle 16 (Auftragsnummer+Name) ein Link zu der Datei aus der ich die Werte hole erzeugt wird.
Geht das?
Vielen Dank für eure Hilfe
Charly
Sub GetData()
Set oMe = ThisWorkbook.ActiveSheet 'ZielDatei/-Tabelle (= die aktuelle Tabelle der aktuellen _
Datei)
Const sDateiPfad As String = "C:\DK Test\" 'Pfad für zu durchsuchende Excel-Dateien; mit _
Backslash am Ende
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")
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
End With
Workbooks(sWbName).Saved = True
Workbooks(sWbName).Close
iZeile = iZeile + 1
End If
Next
End Sub