klasöre gözat xls listele 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] = ""
'ü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")
End Sub

' Muß erwähnt sein: Diese Funktion stammt nicht von mir.
' Die Quelle ist mir nicht mehr bekannt.

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

No	Makro Adı
1	klasöre gözat xls listele
2	klasöre gözat penceresini çağırır
3	b1 hücresine klasör yolunu yaz xls dosyalarını listelesin
4	belirtilen yoldaki xls dosyalarını aktif hücreden itibaren listeler
5	dosya arama 2
6	Bir klasördeki Excel dosyalarının isimlerini listeleyerek daha sonra onlara link vermek
7	tüm makroları seçtiğiniz bir klasördeki excel dosyalarının içindeki makroları listeler
8	yalniz çalışma sayfası kaydetme
9	bulunulan klasöre tarihli yedek alır
10	vbs ile klasör işlemleri
11	forma otomatik resim getirme
12	Klasördeki bütün Excel dosyalarını açma
13	klasörden çalışma sayfası açma ve köprü kurma
14	klasör ve dosya makrolarındaki yolları kendine göre düzenle
15	dosya yolu ve uzantısını belirle ayrıntılı listelesin
16	ağ üzerinden diğer kitaptaki makroyu çalıştırma
17	klasördeki veya dizindeki xls dosyasının boyutunu öğrenme
18	ayrı sayfalardaki belli hücreleri toplatmak
19	belirlediğim verilerin klasör, dosyaadi olarak kaydı
20	kitap ismi ile klasör oluşturur her sayfayı ayrı ayrı olarak kaydet

Excel Hazır Makrolar (VBA)

Klasöre Gözat Xls Listele

Robotik Kodlama

Hizmetler

Size nasıl yardımcı olabiliriz?

Youtube Kanalımıza Abone Oldunuz mu?

Anahtar Kelimeler