• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Dosya ismi ile klasör oluşturma ve içine atma

ASLAN7410

ASLAN7410

Katılım
15 Temmuz 2012
Mesajlar
2,802
Excel Vers. ve Dili
Ofis 2021 TR 64 Bit
Merhaba hayırlı akşamlar, kusura bakmayın yine bir klasör sorusu sormak istiyorum.

Verilerim gerçekten çok fazla olduğu için hep klasörlerle uğraşıyorum.

Ekte gönderdiğim rar klasörü içerisinde BÜTÜN DOSYALAR isimli klasörüm var, bu klasör içerisinde .xls, xlsx, xlsm, doc, docx uzantılı gibi dosyalarım var, ben bu dosya isimleriyle aynı isimle klasör oluşturup, aynı isimli dosyaları aynı isimli klasörün içerisine atmak istiyorum.

Örneğin AHMET isimli excel dosyasını, AHMET isimli klasör oluşturup içerisine atmasını istiyorum.

Forumda ve internette araştırdım ancak böyle bir çalışma bulamadım.

Yardımcı olur musunuz?

http://dosya.co/9lvr4u04lo7b/BÜTÜN_DOSYALAR.rar.html
.
 

Ekli dosyalar

Son düzenleme:
Merhaba,
Aşağıdaki kodu deneyin. Deneme amaçlı mesaj ekledim, isterseniz silebilirsiniz.
İyi çalışmalar..

Sub klasör_oluştur()
Application.DisplayAlerts = False
On Error GoTo h

Dim ds
Set ds = CreateObject("Scripting.FileSystemObject")
ds.CreateFolder "C:\" & ActiveWorkbook.Name & "\"

ActiveWorkbook.SaveAs "C:\" & ActiveWorkbook.Name & "\" & ActiveWorkbook.Name & ".xls"
ActiveWorkbook.Close

MsgBox "klasör oluşturulmuştur"
Exit Sub
h:
MsgBox " Klasör var olduğundan oluşturulmamıştır."
End Sub
 
Son düzenleme:
Sayın acolkesen1 ilginiz için çok teşekkür ederim, ancak göndermiş olduğunuz kodları bir türlü çalıştırıp, klasör oluşturamadım.
 
Alternatif;

Aşağıdaki şekilde deneyiniz.
A2 ye ana klasörü yazın. c:\deneme gibi

http://s9.dosya.tc/server2/pbk7om/Dosyaadi_ile_klasor_olusturma.zip.html

Kod: 
Dim dosyaadi As String
Dim dosyasayisi, kackelime, ensonsatir, ensonsutun, satir As Long
Dim uzanti, aradizin As String

Sub menu()
    Sheets("Menu").Select
    aradizin = Cells(2, 1).Value & "\"
    satir = 0
    Call RecursiveFolder(aradizin)
End Sub

Sub RecursiveFolder(MyPath)
    Dim FileSys As FileSystemObject
    Dim objFolder As Folder
    Dim objSubFolder As Folder
    Dim objFile As File
 
    Set FileSys = CreateObject("Scripting.FileSystemObject")
    Set objFolder = FileSys.GetFolder(MyPath)
 
    For Each objFile In objFolder.Files
        objdosya = objFile.Name
                
        If Left(objdosya, 1) <> "~" And objdosya <> ThisWorkbook.Name Then
          dosyaadi = ""
          dosyauzantisi = ""
          If InStr(objdosya, ".") > 0 Then
             dosyauzanti = Right(objdosya, Len(objdosya) - InStrRev(objdosya, "."))
             dosyaadi = Left(objdosya, InStrRev(objdosya, ".") - 1)
          Else
             dosyaadi = objdosya
          End If
          If Dir(aradizin & dosyaadi, vbDirectory) = "" Then MkDir aradizin & dosyaadi
           FileCopy aradizin & objdosya, aradizin & dosyaadi & "\" & objdosya
           Kill aradizin & objdosya
        End If
son:
    Next objFile
 
    Set FileSys = Nothing
    Set objFolder = Nothing
    Set objSubFolder = Nothing
    Set objFile = Nothing
 
End Sub
 
Son düzenleme:
Sayın asri ilginiz için çok teşekkür ediyorum.

Kodu çalıştırmak için bir tane excel örnek dosyasının Sayfa1'in ismini Menu olarak yazdım, kodu modüle yapıştırdım, A2 hücresine C:\Users\ASLANS\Desktop\BÜTÜN DOSYALAR şeklinde klasör adresini yazdım. Butona bastım ancak
Sub RecursiveFolder(MyPath) bu kısmı sarıya boyuyor
Dim FileSys As FileSystemObject bu kısımnda duruyor ve compile error şeklinde hata veriyor.

Kusura bakmayın bir örnek gönderebilir misiniz?
 

Ekli dosyalar

  • Ekran Alıntısı.jpg
    Ekran Alıntısı.jpg
    21.5 KB · Görüntüleme: 6
Merhaba
Alternatif olarak işinize yararsa örneği deneyiniz.
Asıl dosyanızın "Bütün dosyalar" klasörü dışında olduğunu varsayarak;
ve pencereden "Bütün dosyalar" klasörünü seçiniz.

http://s6.dosya.tc/server8/rhsjwq/Desktop.zip.html
Kod: 
 [SIZE="2"]Private Sub CommandButton1_Click()
Set klasorsec = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
yol = klasorsec.Items.Item.Path
Set nesne = CreateObject("Scripting.FileSystemObject")
Set klasor = nesne.GetFolder(yol)
Set dosyalar = klasor.Files
For Each dosya In dosyalar
kl = Split(dosya.Name, "." & nesne.GetExtensionName(dosya.Name))(0)
If nesne.FolderExists(yol & "\" & kl) = False Then nesne.CreateFolder yol & "\" & kl
yer = yol & "\" & kl & "\"
nesne.moveFile Source:=dosya, Destination:=yer
Next
End Sub[/SIZE]
 
Sayın PLİNT cevabınızı sonradan fark ettim, ellerinize sağlık kodlar süper çalışıyor tam istediğim gibi oldu, beni büyük bir yükten kurtardınız Allah razı olsun.

Hayırlı çalışmalar hayırlı geceler diliyorum.
 
ASLAN7410' Alıntı:
Sayın PLİNT cevabınızı sonradan fark ettim, ellerinize sağlık kodlar süper çalışıyor tam istediğim gibi oldu, beni büyük bir yükten kurtardınız Allah razı olsun.
Hayırlı çalışmalar hayırlı geceler diliyorum.
Genişletmek için tıkla ...
Rica ederim.
Eğer klasör yolu sabit ve anadosya klasörün içinde olacaksa ekleme/değişiklik yaparız.
 
Gerek yok sayın PLİNT, bu şekilde tam istediğim gibi oldu, çok teşekkür ediyorum.
 
ASLAN7410' Alıntı:
Sayın asri ilginiz için çok teşekkür ediyorum.

Kodu çalıştırmak için bir tane excel örnek dosyasının Sayfa1'in ismini Menu olarak yazdım, kodu modüle yapıştırdım, A2 hücresine C:\Users\ASLANS\Desktop\BÜTÜN DOSYALAR şeklinde klasör adresini yazdım. Butona bastım ancak
Sub RecursiveFolder(MyPath) bu kısmı sarıya boyuyor
Dim FileSys As FileSystemObject bu kısımnda duruyor ve compile error şeklinde hata veriyor.

Kusura bakmayın bir örnek gönderebilir misiniz?
Genişletmek için tıkla ...

Mesajıma dosya eklendi.
 
@PLİNT Hocam Klasör Taşı Dosyanızı İndirdim Excel'de Dosya Seçme Ekranı Vardı Sonrasında Neye Göre Dosyalayacağımızı Filtreleme Gelir Diye Düşündüm Ancak 13.854 Dosya Olan Klasörü 13.854 Klasör Oluşturarak Dosyaları İçerisine Attı. Öncelikle Bu Klasörlerin İçinden Dosyaları Toplu Şekilde Nasıl Çıkarabiliriz.

Ayrıca Örneğin;
1d20170128170451p0123
1d20170128154237p0123
1d20170127210626p0123
1d20170127125049p0456
1d20161014143710p0456
1d20161014102311p0789
0d20140906175304p0789
Yukarıdaki Gibi Bir Sürü Dosya İsimlerim Var p Harfinden Önceki Tarihlere Göre Değilde p Harfinden Sonra Aynı Olan Rakamlar Örneğin p'den Sonra 0123 Olanlar Bir Klasörde p'den Sonra 0456 Olanlar Bir Klasörde p'den Sonra 0789 Olanlar Bir Klasörde Olacak Şekilde Nasıl Bir Kodlama Kullanmalıyız.
 
Merhaba
Dosyaları çıkarmak için:
Şu adresdeki dosyayı https://we.tl/t-DpPTcduBYo deneyip.
Oluşmuş 13854 klasörü bir anaklasör içine kopyalayın, "ÇIKARICI.xlsm" dosyasını açıp bu anaklasörü seçin

ikinci isteğinize görede:
Ekdeki dosyayı deneyip: https://we.tl/t-UP3547kWGw
(Adında "p" bulunan dosyalarınızın bulunduğu) klasörürü seçin.

İlk dosya kodları
Kod: 
Private Sub CommandButton1_Click()
Set klasorsec = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", 0, ThisWorkbook.Path)
If IsEmpty(klasorsec) = True Then Exit Sub
yol = klasorsec.Items.Item.Path
Set nesne = CreateObject("Scripting.FileSystemObject")
Set f = nesne.GetFolder(yol)
For Each a In f.subfolders
Set dosyalar = a.Files
For Each dosya In dosyalar
kl = "ÇIKARILANLAR"
If nesne.FolderExists(ThisWorkbook.Path & "\" & kl) = False Then nesne.CreateFolder ThisWorkbook.Path & "\" & kl
yer = ThisWorkbook.Path & "\" & kl & "\"
nesne.moveFile Source:=dosya, Destination:=yer
Next

Next a
End Sub

2. dosya kodları
Kod: 
Private Sub CommandButton1_Click()
Set klasorsec = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
yol = klasorsec.Items.Item.Path
Set nesne = CreateObject("Scripting.FileSystemObject")
Set klasor = nesne.GetFolder(yol)
Set dosyalar = klasor.Files
For Each dosya In dosyalar
kl = Split(dosya.Name, "." & nesne.GetExtensionName(dosya.Name))(0)
kl2 = Split(kl, "p")(UBound(Split(kl, "p")))
If nesne.FolderExists(yol & "\" & kl2) = False Then nesne.CreateFolder yol & "\" & kl2
yer = yol & "\" & kl2 & "\"
nesne.moveFile Source:=dosya, Destination:=yer
Next
End Sub
 
Son düzenleme:
PLİNT' Alıntı:
Merhaba
Dosyaları çıkarmak için:
Şu adresdeki dosyayı https://we.tl/t-DpPTcduBYo deneyip.
Oluşmuş 13854 klasörü bir anaklasör içine kopyalayın, "ÇIKARICI.xlsm" dosyasını açıp bu anaklasörü seçin

ikinci isteğinize görede:
Ekdeki dosyayı deneyip: https://we.tl/t-UP3547kWGw
(Adında "p" bulunan dosyalarınızın bulunduğu) klasörürü seçin.

İlk dosya kodları
Kod: 
Private Sub CommandButton1_Click()
Set klasorsec = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", 0, ThisWorkbook.Path)
If IsEmpty(klasorsec) = True Then Exit Sub
yol = klasorsec.Items.Item.Path
Set nesne = CreateObject("Scripting.FileSystemObject")
Set f = nesne.GetFolder(yol)
For Each a In f.subfolders
Set dosyalar = a.Files
For Each dosya In dosyalar
kl = "ÇIKARILANLAR"
If nesne.FolderExists(ThisWorkbook.Path & "\" & kl) = False Then nesne.CreateFolder ThisWorkbook.Path & "\" & kl
yer = ThisWorkbook.Path & "\" & kl & "\"
nesne.moveFile Source:=dosya, Destination:=yer
Next

Next a
End Sub

2. dosya kodları
Kod: 
Private Sub CommandButton1_Click()
Set klasorsec = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
yol = klasorsec.Items.Item.Path
Set nesne = CreateObject("Scripting.FileSystemObject")
Set klasor = nesne.GetFolder(yol)
Set dosyalar = klasor.Files
For Each dosya In dosyalar
kl = Split(dosya.Name, "." & nesne.GetExtensionName(dosya.Name))(0)
kl2 = Split(kl, "p")(UBound(Split(kl, "p")))
If nesne.FolderExists(yol & "\" & kl2) = False Then nesne.CreateFolder yol & "\" & kl2
yer = yol & "\" & kl2 & "\"
nesne.moveFile Source:=dosya, Destination:=yer
Next
End Sub
Genişletmek için tıkla ...

@PLİNT Hocam Allah Razı Olsun, Teşekkür Ederim. Kolay Gelsin, İyi Çalışmalar.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst