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

TÜM MAKROLAR Youtube Kanalımız
Aşağıdaki makrolar işinize yarayabilir.

Warning: mysql_connect() [function.mysql-connect]: Headers and client library minor version mismatch. Headers:100519 Library:100236 in /home/dbswav/public_html/excelsizeyeter.com/benzerlik_hazir_makrolar4.php on line 19

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