Änderung von Quellcode
13.06.2007 10:12:00
Quellcode
Ich habe ein bestehendes Makro umgeschrieben und möchte nun ein paar Ergänzungen hinzufügen: Das Sheet ist so aufgebaut: A: Dateiname mit Dateiendung, B: derzeit leer, C: ist manuell zu beschriften, D: Ordner, E,F,G enthalten informationen über Größe usw. H: Pfad, I:Hyperlink
Ich möchte in der Spalte B die Dateiendung stehen haben. In der Spalte A soll nur der Dateiname (ohne Endung) stehen.
Und in der Spalte I habe ich manuell mit Makro aufzeichnen eine Hyperlinkerstellung eingefügt. Ich lasse diese bis Zelle I 10000 laufen, ich hätte aber gerne, dass die Hyperlinkerstellung automatisch bis zu letzten Zeile der eingelesenen Dateistruktur durchgeführt wird, weil ich mir so ein wenig Rechenleistung sparen kann, wenn weniger als 10000 Dateien eingelesen werden.
Also hier der Quellcode:
Dim n
Dim dname(65000)
Dim dordner(65000)
Dim dcreated(65000)
Dim dpfad(65000)
Dim dlast(65000)
Dim dsize(65000)
Sub NeuEinlesen()
Set MyShell = CreateObject("wscript.shell")
Set MyFiles = CreateObject("Scripting.FileSystemObject")
Set Appshell = CreateObject("Shell.Application")
On Error Resume Next
Set AppFolder = Appshell.BrowseForFolder(0, "", &H1, 17)
verz = AppFolder.ParentFolder.ParseName(AppFolder.Title).Path
If Err.Number > 0 Then
i = InStr(AppFolder, ":")
verz = Mid(AppFolder, i - 1, 1) & ":\"
End If
If verz = "" Then Exit Sub
If n = 0 Then
Range("A3").Select
Range(Selection, Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
End If
Set drive = MyFiles.GetFolder(verz)
Set dat = drive.Files
For Each datei In dat
n = n + 1
dname(n) = datei.Name
dordner(n) = drive.Path
dpfad(n) = datei.Path
dsize(n) = datei.Size
dcreated(n) = datei.datecreated
dlast(n) = datei.DateLastAccessed
Next
Search drive
For x = 1 To n
Cells(x + 2, 1).Value = dname(x)
Cells(x + 2, 4).Value = dordner(x)
Cells(x + 2, 5).Value = Int(dsize(x) / 1024)
Cells(x + 2, 6).Value = DateValue(Date) - DateValue(dcreated(x))
Cells(x + 2, 7).Value = DateValue(Date) - DateValue(dlast(x))
Cells(x + 2, 8).Value = dpfad(x)
Next
Application.ScreenUpdating = True
m = MsgBox(n & " Dateien eingetragen." & Chr(13) & "Weitere Daten hinzufügen?", 4)
If m = 6 Then NeuEinlesen
Range("A3").Select
Range(Selection, Cells.SpecialCells(xlCellTypeLastCell)).Select
Selection.Sort key1:=Range("D3"), order1:=xlAscending, Key2:=Range("A3") _
, Order2:=xlAscending, header:=xlNo
Range("A2:I2").Select
With Worksheets("Tabelle1")
If Not .AutoFilterMode Then
Selection.AutoFilter
End If
End With
Range("A2").Select
n = 0
End Sub
Sub Search(ByVal StartFolder)
Set Weitere = StartFolder.SubFolders
For Each AktuellerOrdner In Weitere
Set dat = AktuellerOrdner.Files
For Each datei In dat
n = n + 1
dname(n) = datei.Name
dordner(n) = AktuellerOrdner.Path
dpfad(n) = datei.Path
dsize(n) = datei.Size
dcreated(n) = datei.datecreated
dlast(n) = datei.DateLastAccessed
Next
Search AktuellerOrdner
Next
ActiveCell.FormulaR1C1 = "=HYPERLINK(RC[-1])"
Range("I3").Select
Selection.AutoFill Destination:=Range("I3:I10000"), Type:=xlFillDefault
Range("I3:I10000").Select
End Sub
Es wäre super, wenn mir jemand weiterhelfen könnte und den Quellcode abgeändert wieder hier reinstellen könnte, da meine VBA Kenntnisse gleich null sind :-)
Ich bedanke mich jetzt schon für Eure Hilfe im Voraus,
mfg pain007