immernoch nicht
26.08.2003 16:03:44
thomasM
hallo,
ich hab das mal so wie du es geschrieben hast eingesetzt:
Option Explicit
Sub DateienAuflisten()
Dim lngAkt As Long
Dim rngBereich As Range
Dim rngZelle As Range
Dim wksIndex As Worksheet
Dim wksProjekt As Worksheet
Dim strZelle As String
Dim strZellinhalt As String
Dim strArray(1 To 50) As String
Dim wkbName As String
Dim strText As String
Dim intZeileLesen As Integer
Dim intZaehler As Integer
Dim intZeileSchreiben As Integer
Dim intAktivArrayfeld As Integer
Dim intBeschriebeneArrayfelder As Integer
Dim intSpalte As Integer
Dim intAnzahlDateien As Integer
Dim intRow As Integer
'Auslese Variablen
Dim strB3 As String
Dim strB4 As String
Dim strB5 As String
Dim strB6 As String
Dim strB8 As String
Dim strB9 As String
Dim strVerzeichnis As String
Set wksIndex = ThisWorkbook.Sheets(1)
Worksheets("Tabelle1").Range("A4:F65536").ClearContents
strVerzeichnis = Worksheets("Tabelle1").Range("H8").Value
With Application.FileSearch 'Hier werden alle Dateinamen aus einem Ordner
.NewSearch 'in Tabelle 2 Spalte A geschrieben
.LookIn = strVerzeichnis
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
.Execute
For lngAkt = 1 To .FoundFiles.Count
Cells(lngAkt, 1) = Mid(.FoundFiles.Item(lngAkt), Len(strVerzeichnis) + 1)
Next lngAkt
End With 'bis hier werden die Dateinamen in die
'Zellen (A1,A2,A3,...) geschrieben
intZeileLesen = 2
intZeileSchreiben = 4
intBeschriebeneArrayfelder = 1
strZelle = "A1"
intBeschriebeneArrayfelder = 0
intAktivArrayfeld = 1
strZellinhalt = "Anfang"
intAnzahlDateien = 0
Do Until strZellinhalt = "" 'Zellinhalte (Dateinamen) werden solange eingelesen bis die Zelle leer ist
strZellinhalt = Range(strZelle).Value 'Zellinhalt wird in Variable geschrieben
strArray(intAktivArrayfeld) = strZellinhalt 'schreibt Zellinhalt in Array
intAktivArrayfeld = intAktivArrayfeld + 1 'nächstes Arrayfeld wird aktiviert
strZelle = "A" & intZeileLesen
intZeileLesen = intZeileLesen + 1
intAnzahlDateien = intAnzahlDateien + 1
Loop
intBeschriebeneArrayfelder = intAktivArrayfeld - 1
For intAktivArrayfeld = 1 To intBeschriebeneArrayfelder - 1
Workbooks.Open strVerzeichnis & strArray(intAktivArrayfeld) 'Hier sollen die Zellinhalte einzeln
Set wksProjekt = ActiveWorkbook.Sheets(1) 'in das Indexblatt geschrieben werden
wksIndex.Range("B" & intZeileSchreiben) = wksProjekt.Range("B3")
wksIndex.Range("A" & intZeileSchreiben) = wksProjekt.Range("B4")
wkbName = strVerzeichnis & strArray(intAktivArrayfeld)
strText = wksProjekt.Range("B4")
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
wkbName, TextToDisplay:=strText
'2. 'ActiveCell.FormulaR1C1 = wksProjekt.Range("B4")
'ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=strVerzeichnis & strArray(intAktivArrayfeld), TextToDisplay:=wksProjekt.Range("B4")
'3. 'wkbName = strVerzeichnis & strArray(intAktivArrayfeld)
'With Workbooks(wksProjekt.Range("B4")).Worksheets(1)
' intRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
' .Hyperlinks.Add .Cells(intRow, 1), Address:=wkbName
'End With
wksIndex.Range("C" & intZeileSchreiben) = wksProjekt.Range("B5")
wksIndex.Range("D" & intZeileSchreiben) = wksProjekt.Range("B6")
wksIndex.Range("E" & intZeileSchreiben) = wksProjekt.Range("B8")
wksIndex.Range("F" & intZeileSchreiben) = wksProjekt.Range("B9")
Workbooks(Right(strArray(intAktivArrayfeld), Len(strArray(intAktivArrayfeld)) - 1)).Close SaveChanges:=False
intZeileSchreiben = intZeileSchreiben + 1
strArray(intAktivArrayfeld) = ""
Next
Worksheets("Tabelle2").Range("A1:A" & intAnzahlDateien).Delete 'Hier soll der Inhalt von Spalte A gelöscht werden
End Sub
er erstellt mir den Text in der Zelle aber die roten zeilen ignoriert er einfach.
aber eine fehlermeldung kommt auch nicht. komisch
gruß,
thomasM