Alt klasörlerden belirli 1 klasörü silmek

[k0081]

Merhaba arkadaşlar;

C:\deneme\ klasörü altında bulunan çok sayıdaki klasörlerden ve alt klasörlerden ismi orjinal olan klasörleri nasıl silebilirim ? ( command buton ile )

Yardımcı arkadaşa şimdiden teşekkürler

 

[halit3]

Arama kriterine (DeleteFolder) bunu yazın ve aratın.

Ben üç adet linki ekledim.

http://www.excel.web.tr/f48/makro-ile-klasor-silme-t34363.html
http://www.excel.web.tr/f57/klasoru-silme-t41136.html
http://www.excel.web.tr/f48/klas-r-tamamen-s-l-t3865.html

 

[k0081]

Linkleri inceledim. Teşekkürler. Fakat henüz çözüm bulamadım.

 

[halit3]

kod:

Dim veri(650000)
Dim say
Dim aranan

Sub klasorsil()
aranan = InputBox("Aranan klasör adını yazınız.", "Klasör adı", "")
If aranan = False Or aranan = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
say = 0

Liste (Kaynak)

If say > 0 Then
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
For i = say To 1 Step -1
MsgBox veri(i)
DosyaSistemi.DeleteFolder veri(i)
Next
End If

Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
If f.Name = aranan Then
say = say + 1
veri(say) = yol & "\" & f.Name
End If

On Error Resume Next
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

 

[Murat OSMA]

Halit Bey'in müsadesiyle..

Alternatif olarak bu kodlar da kullanılabilir;

[FONT="Trebuchet MS"][SIZE="2"]Public Fso As Object, Evn As Object, Klasörler As Object, i%, dosya$

Sub Dizindeki_Tüm_Klasörleri_Tara()
    dosya = Application.[COLOR="red"]InputBox[/COLOR]("Silinecek Klasör Adını Yazın", "[URL="http://www.muratosma.com"]Www.MuratOSMA.Com[/URL]")
    Call Ara([COLOR="Red"]ThisWorkbook.Path[/COLOR])
    Set Fso = Nothing: Set Evn = Nothing: Set Klasörler = Nothing
End Sub

Public Function Ara(ByVal Dizin As String)
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Evn = Fso.[COLOR="Red"]GetFolder[/COLOR](Dizin): Ara = 0
    For Each Klasörler In Evn.[COLOR="Red"]Subfolders[/COLOR]
[COLOR="Red"]            If LCase(Klasörler.Name) = LCase(dosya) Then[/COLOR]
            Fso.[COLOR="red"]DeleteFolder [/COLOR]Klasörler
            Exit For
       End If
        i = i + 1
        Ara = Ara + 1 + Ara(Klasörler.Path)
    Next Klasörler
End Function[/SIZE][/FONT]

 

[halit3]

Murat Bey Merhaba
Ekli rar dosyasında boş klasörler ve bir adet excel dosyası mevcut klasör ve dosyaları rar dan çıkartın dosyayı açın önce klasörleri listele düğmesine tıkla açılan kutuya (a) yaz ve tamamı tıklayın (a) klasörlerinin adresini sayfaya listeliyor sonra sizin yazdığınız kodu tıklayın işlem bitince listele düğmesine yeniden tıklayın ve sonuçları gözlemleyin.

Diğer taraftan aynı olayı klasörsil düğmesine tıklayarakda deneyiniz.

 

[Murat OSMA]

Halit Bey, gönderdiğim kodda bir hata ya da eksiklik var?
Tam olarak anlamadım. :dusun:​

 

[halit3]

Murat Bey kod bu şekliyle çalışıyor.

Sub Dizindeki_Tüm_Klasörleri_Tara()
Dosya = Application.InputBox("Silinecek Klasör Adını Yazın", "Www.MuratOSMA.Com")
Call Ara(ThisWorkbook.Path)
Set Fso = Nothing: Set Evn = Nothing: Set Klasörler = Nothing
End Sub

Private Sub Ara(yol As String)
Dim Fso As Object, Klasörler As Object, j As Long
Set Fso = CreateObject("Scripting.FileSystemObject")

On Error GoTo sonraki

For Each Klasörler In Fso.GetFolder(yol).Subfolders
If LCase(Klasörler.Name) = LCase(Dosya) Then
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = Klasörler
Cells(j, 2) = Klasörler.Name
Fso.DeleteFolder Klasörler
End If
Ara (Klasörler.Path)
sonraki:

Next Klasörler
End Sub

 

[halit3]

Bu kod da aynı işlemi yapıyor.

Dim aranan

Sub klasörleri_sil2()
aranan = LCase(InputBox("Aranan klasör adını yazınız.", "Klasör adı", ""))

If aranan = False Or aranan = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If
Range("A2:B65000").ClearContents
Liste1 (ThisWorkbook.Path)
MsgBox "işlem tamam"
End Sub
Private Sub Liste1(yol As String)
Dim fL As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
For Each f In fL.GetFolder(yol).Subfolders

If LCase(f.Name) = aranan Then
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = f
Cells(j, 2) = f.Name
fL.DeleteFolder f
End If

'On Error Resume Next
Liste1 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

 

[k0081]

Sn. Halit ve Murat hocam ; pc başında değilim kodları deneyip sonuç yazarım çok teşekkür ederim.

***


Halit hocam ; 4 nolu mesajınız daki kodları inceledim ve denedim. Sorunsuz bir şekilde çalışıyor..

Murat hocam; 5 nolu mesajınız daki Alternatif kodları inceledim ve denedim. Sorunsuz bir şekilde çalışıyor..

Çok teşekkür ediyorum.. Tamamdır.. saygılar..

 

[halit3]

Sn. Halit ve Murat hocam ; pc başında değilim kodları deneyip sonuç yazarım çok teşekkür ederim.

***


Halit hocam ; 4 nolu mesajınız daki kodları inceledim ve denedim. Sorunsuz bir şekilde çalışıyor..

Murat hocam; 5 nolu mesajınız daki Alternatif kodları inceledim ve denedim. Sorunsuz bir şekilde çalışıyor..

Çok teşekkür ediyorum.. Tamamdır.. saygılar..

Teşekkürler iyi çalışmalar