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

ASLAN7410 · 13 Şubat 2017

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
.

acolkesen1 · 13 Şubat 2017

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

ASLAN7410 · 13 Şubat 2017

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.

Asri · 13 Şubat 2017

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

ASLAN7410 · 13 Şubat 2017

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?

PLİNT · 13 Şubat 2017

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]

ASLAN7410 · 13 Şubat 2017

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.

PLİNT · 13 Şubat 2017

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.

Rica ederim.
Eğer klasör yolu sabit ve anadosya klasörün içinde olacaksa ekleme/değişiklik yaparız.

ASLAN7410 · 13 Şubat 2017

Gerek yok sayın PLİNT, bu şekilde tam istediğim gibi oldu, çok teşekkür ediyorum.

Asri · 13 Şubat 2017

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?

Mesajıma dosya eklendi.

batacakir · 25 Mayıs 2020

@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.

PLİNT · 26 Mayıs 2020

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

batacakir · 27 Mayıs 2020

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

@PLİNT Hocam Allah Razı Olsun, Teşekkür Ederim. Kolay Gelsin, İyi Çalışmalar.

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

ASLAN7410

Altın Üye

Ekli dosyalar

acolkesen1

ASLAN7410

Altın Üye

Asri

ASLAN7410

Altın Üye

Ekli dosyalar

PLİNT

ASLAN7410

Altın Üye

PLİNT

ASLAN7410

Altın Üye

Asri

batacakir

PLİNT

batacakir