Klasör içinde bulunan dosyaları isimlerine göre yenı klasörlere dagıtabılır mıyız

[kakara]

Merhaba ustadlarım yaklasık 10 bın adet excellı bır klasörum mevcut ben bunu excel ısımlerının ıcerısınde gecen ıbarelere göre dagıtmak ıstıyorum mumkun mudur ? şöyle örnek vermek gerekırse

765 BAYAN XL BİSİKLET YAKA KISA KOL ETEGİ OVAL KAPRİ ( excel dosya ısmım )
2594 ERKEK P.SÜPREM V YAKA UZUN KOL GÖGÜS ŞERİTLİ PİJAMA TK
5129 BAYAN KADİFE V YAKA FAS PİJAMA
3301 KIZ ÇOCUK İKİ İPLİK BİSİKLET YAKA ETEK KOL AGZI PAÇASI MANŞETLİ PİJAMA TAKIM

bu sekılde yaklasık 10 bın excel mevcut ben excel ısımlerıne göre ılk önce kumas cınsıne göre klasörlere ayırmak ıstıyorum ( suprem - süprem ) yazanların hepsı bır klasör ıcıne daha sonra da süprem klasörunun ıcınde bayanlar bayan klasörune erkekler erkek klasörune olucak.


ılgınız ıcın sımdıden tesekkurler.

 

[volki_112]

Merhaba ustadlarım yaklasık 10 bın adet excellı bır klasörum mevcut ben bunu excel ısımlerının ıcerısınde gecen ıbarelere göre dagıtmak ıstıyorum mumkun mudur ? şöyle örnek vermek gerekırse

765 BAYAN XL BİSİKLET YAKA KISA KOL ETEGİ OVAL KAPRİ ( excel dosya ısmım )
2594 ERKEK P.SÜPREM V YAKA UZUN KOL GÖGÜS ŞERİTLİ PİJAMA TK
5129 BAYAN KADİFE V YAKA FAS PİJAMA
3301 KIZ ÇOCUK İKİ İPLİK BİSİKLET YAKA ETEK KOL AGZI PAÇASI MANŞETLİ PİJAMA TAKIM

bu sekılde yaklasık 10 bın excel mevcut ben excel ısımlerıne göre ılk önce kumas cınsıne göre klasörlere ayırmak ıstıyorum ( suprem - süprem ) yazanların hepsı bır klasör ıcıne daha sonra da süprem klasörunun ıcınde bayanlar bayan klasörune erkekler erkek klasörune olucak.


ılgınız ıcın sımdıden tesekkurler.

Alttaki kodu kullanabilirsiniz. Öncelikle bu excel dosyalarin hepsi ayni klasörün icinde olsun. Daha sonra o klasorde yeni bir excel dosyasi acin. Module alttaki kodu yazin. Bu excel dosyasina bir sekil ekleyin. Sag tiklayip makro ata deyip bu kodu atayin. Simdi bu excel dosyasinda A1 Hücresine istediginuz kelimeyi yazip butona basiniz. O kelimenin gectigi excel dosyalarini yeni bir klasor acip oraya tasir. Bu kod sadece bulundugu klasordeki excelleri tarar. Bu exceli baska klasore taşıyın orada da calsitirin sonra.

Sub DosyalariTaraVeTasi()

    Dim aranacakKelime As String
    Dim anaKlasor As String, yeniKlasor As String
    Dim dosyaAdi As String

    aranacakKelime = Range("A1").Value          ' A1'den kelimeyi al
    If aranacakKelime = "" Then
        MsgBox "A1 hücresine aranacak kelime yazılmalıdır!", vbExclamation
        Exit Sub
    End If

    anaKlasor = ThisWorkbook.Path & "\"         ' Excel dosyasının olduğu klasör
    yeniKlasor = anaKlasor & aranacakKelime     ' Yeni klasör yolu

    ' --- Klasör yoksa oluştur ---
    If Dir(yeniKlasor, vbDirectory) = "" Then
        MkDir yeniKlasor
    End If

    dosyaAdi = Dir(anaKlasor & "*.xls*")        ' Excel dosyalarını tara (xlsx, xlsm, xlsbus)

    Do While dosyaAdi <> ""
        If InStr(1, dosyaAdi, aranacakKelime, vbTextCompare) > 0 Then
            ' Bulunan dosyayı taşı
            Name anaKlasor & dosyaAdi As yeniKlasor & "\" & dosyaAdi
        End If
        dosyaAdi = Dir
    Loop

    MsgBox "İşlem tamamlandı. Bulunan dosyalar '" & aranacakKelime & "' klasörüne taşındı.", vbInformation

End Sub

 

[kakara]

ustadım kod calısıyor tesekkurler