AW: Ansatz zur Auswahl
02.08.2013 13:12:25
Karl-Ludwig
Hallo Frank,
Wunderbar!
Sub test1()
On Error GoTo fehler
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Pfad As String, Dateiname As String, iRow As Long, Ordner As String, Datum As String
Dim fs
Dim f
Dim fl
Dim Datei
Dim FNS
Ordner = InputBox("Ordner angeben (z.B. 07_2013)")
Pfad = "L:\Produktion\" & Ordner & "\"
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getfolder(Pfad)
Set fl = f.Files
For Each Datei In fl
'Suchkriterium folgt, evtl mit INSTR den Unterstrich suchen
'und mit diesem Rückgabewert-1 den Parameter für LEFT anpassen
FNS = Left(Datei.Name, 2)
If IsNumeric(FNS) Then
Dateiname = Dir(Pfad & "*.xls")
GetObject (Datei)
Datum = Workbooks(Dateiname).BuiltinDocumentProperties("last save time")
iRow = ThisWorkbook.Sheets("Tabelle1").Range("A65536").End(xlUp).Offset(1, 0).Row
ThisWorkbook.Sheets("Tabelle1").Cells(iRow, 1) = Datum
Workbooks(Dateiname).Sheets("Tabelle1").Range("D5").Copy
ThisWorkbook.Sheets("Tabelle1").Cells(iRow, 2).PasteSpecial Paste:=xlPasteValues
Workbooks(Dateiname).Sheets("Tabelle1").Range("D6").Copy
ThisWorkbook.Sheets("Tabelle1").Cells(iRow, 3).PasteSpecial Paste:=xlPasteValues
Workbooks(Dateiname).Sheets("Tabelle1").Range("H6").Copy
ThisWorkbook.Sheets("Tabelle1").Cells(iRow, 4).PasteSpecial Paste:=xlPasteValues
Workbooks(Dateiname).Sheets("Tabelle1").Range("I6").Copy
ThisWorkbook.Sheets("Tabelle1").Cells(iRow, 5).PasteSpecial Paste:=xlPasteValues
Workbooks(Dateiname).Sheets("Tabelle1").Range("H7").Copy
ThisWorkbook.Sheets("Tabelle1").Cells(iRow, 6).PasteSpecial Paste:=xlPasteValues
Workbooks(Dateiname).Sheets("Tabelle1").Range("I7").Copy
ThisWorkbook.Sheets("Tabelle1").Cells(iRow, 7).PasteSpecial Paste:=xlPasteValues
Workbooks(Dateiname).Sheets("Tabelle1").Range("I34").Copy
ThisWorkbook.Sheets("Tabelle1").Cells(iRow, 8).PasteSpecial Paste:=xlPasteValues
Workbooks(Dateiname).Sheets("Tabelle1").Range("I35").Copy
ThisWorkbook.Sheets("Tabelle1").Cells(iRow, 9).PasteSpecial Paste:=xlPasteValues
Workbooks(Dateiname).Sheets("Tabelle1").Range("I36").Copy
ThisWorkbook.Sheets("Tabelle1").Cells(iRow, 10).PasteSpecial Paste:=xlPasteValues
Workbooks(Dateiname).Sheets("Tabelle1").Range("I38").Copy
ThisWorkbook.Sheets("Tabelle1").Cells(iRow, 11).PasteSpecial Paste:=xlPasteValues
Workbooks(Dateiname).Sheets("Tabelle1").Range("G38").Copy
ThisWorkbook.Sheets("Tabelle1").Cells(iRow, 12).PasteSpecial Paste:=xlPasteValues
Workbooks(Dateiname).Sheets("Tabelle1").Range("J38").Copy
ThisWorkbook.Sheets("Tabelle1").Cells(iRow, 13).PasteSpecial Paste:=xlPasteValues
Workbooks(Dateiname).Sheets("Tabelle1").Range("C10").Copy
ThisWorkbook.Sheets("Tabelle1").Cells(iRow, 14).PasteSpecial Paste:=xlPasteValues
'ThisWorkbook.Sheets("Tabelle1").Cells(iRow, 15).Hyperlinks.Add Anchor:=Selection, _
Address:="Pfad & Dateiname", TextToDisplay:="Dateiname"
Workbooks(Dateiname).Close False
Name Pfad & Dateiname As Pfad & "A_" & Dateiname
Dateiname = Dir()
fehler:
Application.Calculation = xlCalculationAutomatic
End If
Next
End Sub
Hast Du noch eine Idee zu der Zeile?:
ThisWorkbook.Sheets("Tabelle1").Cells(iRow, 15).Hyperlinks.Add Anchor:=Selection, Address:=" _
Pfad & Dateiname", _
TextToDisplay:="Dateiname"
Das mit dem Hyperlink funktioniert nicht :-(
Vielen Dank+ Gruß
KL