title image


Smiley probier mal folgende lösung
hallo holzwura

probier mal folgende lösung (vba)

gruss stefan



' von skl_bi für spotlight :)



Public Type BROWSEINFO

hOwner As Long

pidlRoot As Long

pszDisplayName As String

lpszTitle As String

ulFlags As Long

lpfn As Long

lParam As Long

iImage As Long

End Type



Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long



Sub Verzeichnisse_auflisten()

Dim Pfad1, Name1, Anzahl, x, X0, X1, X2, Verz, Anzverz, Größe

Dim TB1, TB2 As Worksheet

Dim msg As String

Set TB1 = ThisWorkbook.Worksheets(1)

Set TB2 = ThisWorkbook.Worksheets(2)

Start = Now

TB1.[a:D] = ""

TB2.[a:D] = ""

'überflüssige Tabellenblätter löschen

If ThisWorkbook.Worksheets.Count > 2 Then

Application.DisplayAlerts = False

For x = 3 To ThisWorkbook.Worksheets.Count

ThisWorkbook.Worksheets(3).Delete

Next x

Application.DisplayAlerts = True

End If



' Pfad abfragen

msg = "Wählen Sie bitte einen Ordner aus:"

Pfad1 = getdirectory(msg)

If Pfad1 = "" Then Exit Sub

Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen.

TB1.[a2] = Pfad1

Anzahl = 2

TB1.[a1] = "Pfad"

TB1.[b1] = "UnterVerz."

TB1.[C1] = "Anz. Dateien"

TB1.[d1] = "Datgröße in Verz."

X0 = 2

X1 = 2

Do While TB1.Cells(Rows.Count, 1).End(xlUp).Row TB1.Cells(Rows.Count, 2).End(xlUp).Row

For X2 = X0 To X1



Pfad1 = TB1.Cells(X2, 1) ' Pfad setzen.

If Right(Pfad1, 1) "\" Then Pfad1 = Pfad1 & "\"

Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen.

Verz = 0

Do While Name1 "" ' Schleife beginnen.

' Aktuelles und übergeordnetes Verzeichnis ignorieren.

If Name1 "." And Name1 ".." Then

' Mit bit-weisem Vergleich sicherstellen, daß Name1 ein

' Verzeichnis ist.

If (GetAttr(Pfad1 & Name1) And vbDirectory) = vbDirectory Then

Anzahl = Anzahl + 1

TB1.Cells(Anzahl, 1) = Pfad1 & Name1 & "\"

Verz = Verz + 1

'Eintrag nur anzeigen, wenn es sich um ein Verzeichnis handelt.

End If

End If

Name1 = Dir ' Nächsten Eintrag abrufen.

Loop

TB1.Cells(X2, 2) = Verz

Next X2

X0 = X1 + 1

X1 = X2

Loop



'Dateien aus den Verzeichnissen auslesen



Anzverz = TB1.Cells(Rows.Count, 1).End(xlUp).Row

i = 1

ii = 0

For Verz = 2 To Anzverz

Anzahl = 0

Größe = 0

Set fs = CreateObject("Scripting.FileSystemObject")

Set f = fs.GetFolder(TB1.Cells(Verz, 1))

Set fc = f.Files



For Each f1 In fc

If i = 65536 Then

ii = ii + 1

ThisWorkbook.Worksheets.Add.Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)

ThisWorkbook.Worksheets(ii + 2).name = "Dateien " & ii + 1

Set TB2 = ThisWorkbook.Worksheets(ii + 2)

i = 1

End If

i = i + 1

Anzahl = Anzahl + 1

TB2.Cells(i, 1) = f1.name

TB2.Cells(i, 2) = f & "\" & f1.name

'Hyperlink auf die Datei einfügen

TB2.Hyperlinks.Add Anchor:=TB2.Cells(i, 2), Address:= _

f & "\" & f1.name

TB2.Cells(i, 3) = FileLen(f1)

TB2.Cells(i, 4) = FileDateTime(f1)

Größe = Größe + FileLen(f1)

Next

TB1.Cells(Verz, 3) = Anzahl

TB1.Cells(Verz, 4) = Größe / 1024 / 1024

Next Verz

'MsgBox (ii * 65536) + i

ende = Now

MsgBox "Anzahl der Verzeichnisse: " & Verz & Chr(13) & _

"Anzahl der Dateien: " & (ii * 65536) + i & Chr(13) & _

Chr(13) & "Dauer: " & Format(ende - Start, "nn:ss")





SortVerz



UntersteEbenehervorhebenVerz



SortDat



UntersteEbenehervorhebenDat



End Sub



Function getdirectory(Optional msg) As String

Dim bInfo As BROWSEINFO

Dim Path As String

Dim r As Long, x As Long, pos As Integer

' Ausgangsordner = Desktop

bInfo.pidlRoot = 0&

' Dialogtitel

If IsMissing(msg) Then

bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."

Else

bInfo.lpszTitle = msg

End If

' Rückgabe des Unterverzeichnisses

bInfo.ulFlags = &H1

' Dialog anzeigen

x = SHBrowseForFolder(bInfo)

' Ergebnis gliedern

Path = Space$(512)

r = SHGetPathFromIDList(ByVal x, ByVal Path)

If r Then

pos = InStr(Path, Chr$(0))

getdirectory = Left(Path, pos - 1)

Else

getdirectory = ""

End If

End Function



Sub UntersteEbenehervorhebenVerz()

Dim c As Range

Set r = Range("a1:a65000")

For Each c In r.Cells

With c

For int_Pos = Len(c) - 1 To 1 Step -1

If Mid(.Text, int_Pos, 1) = "\" Then

.Characters(1, int_Pos).Font.Bold = False

.Characters(int_Pos + 1, Len(.Text)).Font.Bold = True

Exit For

End If

Next

End With

Next

End Sub







Sub UntersteEbenehervorhebenDat()

Dim c As Range

Dim int_Pos1 As Integer

Dim int_Pos2 As Integer

Dim int_Vonrechts As Integer



Set r = Range("b1:b65000")

int_Vonrechts = 2



For Each c In r.Cells

int_Ebene = 0

int_Pos2 = 0

With c

For int_Pos1 = Len(c) - 1 To 1 Step -1

If Mid(.Text, int_Pos1, 1) = "\" Then

int_Ebene = int_Ebene + 1

If int_Ebene = int_Vonrechts Then

.Font.Bold = False

.Characters(int_Pos1 + 1, int_Pos2 - int_Pos1).Font.Bold = True

Exit For

Else

int_Pos2 = int_Pos1

End If

End If

Next

End With

Next

End Sub







Sub SortVerz()



Sheets("Verzeichnisse").Select

Range("A1").Select



Columns("A:D").Select

Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom



Range("A1").Select



End Sub





Sub SortDat()



Sheets("Dateien").Select

Range("A1").Select



Columns("A:D").Select

Selection.Sort Key1:=Range("b2"), Order1:=xlAscending, Header:=xlGuess, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom



Range("A1").Select



End Sub














Suche in meinen 22.000 Zitaten
mittels Volltextsuche ! HIER

Und hier in mein Excel-Tips

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: