Dateiname als Hyperlink in Auflistung

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Highman4! (hast du auch einen "echten" Namen?)
Ersetze diese Prozedur.
Public Sub ReadFromFile_ADO()
Dim Col As ADODB.Field
Dim objFS As FileSearch
Dim objSh As Worksheet
Dim strPath As String
Dim intIndex As Integer
Dim objADO As Object
Dim lngRow As Long, intCol As Integer
Dim blnFirst As Boolean

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlCalculationManual
  .Cursor = xlWait
End With

Set objSh = Sheets("Ausgabe")

objSh.Range("A2:H65536").ClearContents
objSh.Range("A2:A65536").ClearFormats

strPath = "C:\Walter\Spargel\Faxe2006" ' Pfad zu den Dateien - Anpassen!

lngRow = 2 ' Startzeile der Datenausgabe - Anpassen!

Set objFS = Application.FileSearch

With objFS
  .NewSearch
  .LookIn = strPath
  .FileType = msoFileTypeExcelWorkbooks
  .SearchSubFolders = False

  If .Execute > 0 Then

    For intIndex = 1 To .FoundFiles.Count

      blnFirst = True

      Set objADO = ExcelTable(.FoundFiles(intIndex), "Faxe", "A15:H35")

      Do Until objADO.EOF

        For Each Col In objADO.fields

          If (IsNull(Col.Value) Or Col.Value = "") And intCol = 0 Then Exit For

          intCol = intCol + 1
          objSh.Cells(lngRow, intCol) = Col.Value

          If blnFirst Then
            objSh.Hyperlinks.Add Anchor:=objSh.Cells(lngRow, intCol), Address:=.FoundFiles(intIndex)
            blnFirst = False
          End If

        Next
        If intCol > 0 Then lngRow = lngRow + 1
        intCol = 0
        objADO.MoveNext
      Loop

      objADO.Close

      Set objADO = Nothing

    Next

  End If

End With

Set objFS = Nothing
Set objSh = Nothing

ErrExit:

If Err.Number > 0 Then
  MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
  Err.Clear
End If

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .DisplayAlerts = True
  .Calculation = xlCalculationAutomatic
  .Cursor = xlDefault
End With

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

Dateiname als Hyperlink in Auflistung

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Dateiname als Hyperlink in Auflistung

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread