dosya yolunu göster ayrıntılı olarak listelesin dosyaların kapladıkları alanları, dosya yolunu vs… Hazır Excel Makroları (VBA) | Excel Programları

Makroyu Kopyala

'Excel Makro (VBA) online eğitimleri için: https://www.excelsizeyeter.com/excelsizeyeter.com/udemy_giris.php adresine tıklayınız. Bir eğitim alana bir eğitim bedavadır. İkinci eğitim olarak Excel, Excel pratik çözümler, finans eğitimleri vb. alabilirsiniz. 
 
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] = ""
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

msg = "Wählen Sie bitte einen Ordner aus:"
    Pfad1 = getdirectory(msg)
    If Pfad1 = "" Then Exit Sub
    Name1 = Dir(Pfad1, vbDirectory)
    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)
        If Right(Pfad1, 1)  "" Then Pfad1 = Pfad1 & ""
        Name1 = Dir(Pfad1, vbDirectory)
        Verz = 0
        Do While Name1  ""
        If Name1  "." And Name1  ".." Then
        If (GetAttr(Pfad1 & Name1) And vbDirectory) = vbDirectory Then
        Anzahl = Anzahl + 1
        TB1.Cells(Anzahl, 1) = Pfad1 & Name1 & ""
        Verz = Verz + 1
        End If
        End If
        Name1 = Dir
        Loop
        TB1.Cells(X2, 2) = Verz
        Next X2
        X0 = X1 + 1
        X1 = X2
    Loop
    
    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")
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&
    If IsMissing(msg) Then
        bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
    Else
        bInfo.lpszTitle = msg
    End If
    bInfo.ulFlags = &H1
    X = SHBrowseForFolder(bInfo)
    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

Benzer Sonuçlar
No	Makro Adı
1	dosya yolunu göster ayrıntılı olarak listelesin dosyaların kapladıkları alanları, dosya yolunu vs…
2	b1 hücresine klasör yolunu yaz xls dosyalarını listelesin
3	excelde kendi eklenti ve fonksiyonlarınızı oluşturun
4	menü çubuğunun silinmesi ve özel bir menünün oluşturulması
5	mp3 dosyasının süresini hesaplatın (dosya yolunu yazın ve o hücreyi seçin)
6	dosya yolu ve uzantısını belirle ayrıntılı listelesin
7	excel sayfasında yazılanları texte çevirmek
8	dosyanın bayt cinsinden büyüklüğü nedir?
9	30 excel dosyası içinde bir kelime aratma
10	dosya adı, yolu ve çalışma sayfası adını fornsiyonlarla yazdır
11	dosyanın yolunu ve ismini hücreye yazdırır
12	makro ile form import etmek
13	Dosyayı kim açtı 2
14	excel dosyamin kisayolunu masaüstünde oluşturmak için api
15	dosyayı kim açtı
16	altbilgide dosya yolunu yazar
17	Outlook ile mail gönderme veya toplu mail gönderme
18	Bir klasördeki Excel dosyalarının isimlerini listeleyerek daha sonra onlara link vermek
19	tüm makroları seçtiğiniz bir klasördeki excel dosyalarının içindeki makroları listeler
20	dosya yolunda excel dosyalarını bulur ve açar

Benzer Sonuçlar

Makro Adı

dosya yolunu göster ayrıntılı olarak listelesin dosyaların kapladıkları alanları, dosya yolunu vs…

b1 hücresine klasör yolunu yaz xls dosyalarını listelesin

excelde kendi eklenti ve fonksiyonlarınızı oluşturun

menü çubuğunun silinmesi ve özel bir menünün oluşturulması

mp3 dosyasının süresini hesaplatın (dosya yolunu yazın ve o hücreyi seçin)

dosya yolu ve uzantısını belirle ayrıntılı listelesin

excel sayfasında yazılanları texte çevirmek

dosyanın bayt cinsinden büyüklüğü nedir?

30 excel dosyası içinde bir kelime aratma

dosya adı, yolu ve çalışma sayfası adını fornsiyonlarla yazdır