Dosya adıyla klasör oluştur, dosyaları o klasöre at, klasörü

VBA Makrolar ile ilgili sormak istedikleriniz, yapmak istedikleriniz hakkında yardım alabileceğiniz bölümdür.

Dosya adıyla klasör oluştur, dosyaları o klasöre at, klasörü

İleti#1)  yunus788 » 13 Ekm 2020 18:46

elamun aleyküm arkadaşlar.Benim için zor ama işi bilen için çok zor olmadığını düşündüğüm bir konuda yardım rica ediyorum.film arsivi meraklısıyım.
C downloads klasörüne film ve o filmin posterini download manager ile indiriyorum, film mkv poster jpg uzantılı.
Benim yazmak istediğim kod, 10 saniyede bir downloads klasöründeki dosyaları kontrol etsin, dosya sayısı 2 olunca(film ve poster) mkv uzantılı videonun adıyla bir klasör oluştursun, 2 dosyayı bu klasöre atıp en son bu klasörü c arsiv adlı klasörün içine atsın. Bunu yapabilirmiyim, adet arttıkca tek tek el ile zor oluyo.
Kullanıcı avatarı
yunus788
 
Kayıt: 22 Arl 2019 18:44
Meslek: textil
Yaş: 42
İleti: 7
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: istanbul

Cevap: Dosya adıyla klasör oluştur, dosyaları o klasöre at,

İleti#2)  Miraç CAN » 14 Ekm 2020 08:14

Benim yazmak istediğim kod, 10 saniyede bir downloads klasöründeki dosyaları kontrol etsin, dosya sayısı 2 olunca

Oldu da denk geldi, 2'den fazla olursa ne olacak..?
Kullanıcı avatarı
Miraç CAN
Site Dostu
 
Kayıt: 26 Arl 2016 19:07
Meslek: Harita/Ölçme
Yaş: 39
İleti: 752
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Amasya & Adana

Cevap: Cevap: Dosya adıyla klasör oluştur, dosyaları o klasö

İleti#3)  yunus788 » 14 Ekm 2020 18:59

Miraç CAN yazdı:
Benim yazmak istediğim kod, 10 saniyede bir downloads klasöründeki dosyaları kontrol etsin, dosya sayısı 2 olunca

Oldu da denk geldi, 2'den fazla olursa ne olacak..?


film boyutu yuksek olduğu için ve tek tek indirdiği için bu ihtimal zor, ama her mkv uzantılı dosya için ayrı klasörde açılabilir.
Kullanıcı avatarı
yunus788
 
Kayıt: 22 Arl 2019 18:44
Meslek: textil
Yaş: 42
İleti: 7
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: istanbul

Cevap: Dosya adıyla klasör oluştur, dosyaları o klasöre at,

İleti#4)  Miraç CAN » 15 Ekm 2020 10:25

Sorun .mkv değil .jpg dosyalarında, malumunuz üzere küçük boyutlu olduğundan, çoklu indirmelerde birden fazla .jpg olabileceğinden posterler karışır, nasıl ayırt edebiliriz diye önermek istemiştim.

Ayırt etme ve isteğiniz üzere birden fazla ihtimalini yok sayarak, ilgili klasörde ne kadar .jpg dosyası varsa hepsini taşır.
Önemli Hatırlatmalar:
  1. Dosya yollarını kontrol edip düzenleyin FldrDLoad ve FldrArch
  2. FldrDLoad = Environ$("UserProfile") & "\Downloads" C:\Kullanıcılar\Kullanıcı\İndirilenler yoludur
  3. Environ$("UserProfile") komutu C:\Kullanıcılar\Kullanıcı yolunuzu otomatik belirler C:\Users\User gibi...
  4. "\Downloads" indirme klasör isminizdir
  5. If FSO.GetFolder(FldrDLoad).Files.Count - 1 = 2 Then satırında ki -1 rakamı, sistem tarafından kullanılan fakat klasörde göremediğiniz dosya sayısıdır, sizde farklı olabilir, düzeltmeniz gerekir. Örneğin desktop.ini gibi. Göremezsiniz fakat ilgili klasör yoluna \desktop.ini ekleyip "Enter" yaptığınızda görüntülenir.C:\Users\User\Downloads\desktop.ini gibi...
  6. Göremediğiniz dosya tespit etmek için bu kodu çalıştırıp kontrol edebilirsiniz; ilgili klasördeki dosya isimlerini listeler, klasörleri ve içerdiği dosyaları kapsamaz.
    Boş bir sayfada deneyin:
    Kod: Tümünü seç
    Sub FilesList()
    FileListFolder = "C:\Users\User\Downloads"
    For Each Fls In CreateObject("Scripting.FileSystemObject").GetFolder(FileListFolder).Files
        Cells(Rows.Count, 1).End(3)(2, 1) = Fls.Name
    Next Fls
    End Sub

    Gerekli kontrolden sonra ilgili satırdaki -1 değerini düzeltip, kullanmaya başlayabilirsiniz.
  7. İlgili Excel dosyası açıldığı andan itibaren, her 10 saniyede bir işlem yapar, dosya kapatılınca sonlanır.
Kodları ThisWorkbook/BuÇalışmaKitabı sayfası kod bölümüne ekleyin:
Kod: Tümünü seç
Dim AutoTime As Date
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.OnTime AutoTime, ThisWorkbook.CodeName & ".Arşivle", , False
End Sub
Private Sub Workbook_Open()
AutoTime = Now + TimeSerial(0, 0, 10)
Application.OnTime AutoTime, ThisWorkbook.CodeName & ".Arşivle"
End Sub

Kod: Tümünü seç
Private Sub Arşivle()
AutoTime = Now + TimeSerial(0, 0, 10)
Application.OnTime AutoTime, ThisWorkbook.CodeName & ".Arşivle"
Dim FSO As Object, DFiles As Object, FldrDLoad$, FldrArch$, NewFldr$
Set FSO = CreateObject("Scripting.FileSystemObject")
FldrDLoad = Environ$("UserProfile") & "\Downloads": FldrArch = "C:\Arşiv"
If FSO.GetFolder(FldrDLoad).Files.Count - 1 = 2 Then
    For Each DFiles In FSO.GetFolder(FldrDLoad).Files
        If FSO.GetExtensionName(DFiles) = "mkv" Then
            NewFldr = FldrArch & Application.PathSeparator & FSO.GetBaseName(DFiles)
            FSO.CreateFolder NewFldr
            DFiles.Move NewFldr & Application.PathSeparator
            FSO.MoveFile FldrDLoad & Application.PathSeparator & "*.jpg", NewFldr & Application.PathSeparator
            Exit For
        End If
    Next
End If
End Sub
Kullanıcı avatarı
Miraç CAN
Site Dostu
 
Kayıt: 26 Arl 2016 19:07
Meslek: Harita/Ölçme
Yaş: 39
İleti: 752
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Amasya & Adana

REKLAM
Excel Logo XML Oluşturucu
Logo Object Designer ile Uyarlama

Cevap: Dosya adıyla klasör oluştur, dosyaları o klasöre at,

İleti#5)  yunus788 » 15 Ekm 2020 21:04

Sayın Miraç Can, alakanız için teşekkür ederim verdiğiniz kodlar gayet güzel çalışıyor hem zahmetten kurtardınız hemde kod arsivime yeni kodlar kattım :)
Kendime göre bir iki ekleme yaptım mesela uzun ve karışık olan jpg dosyasının ismini poster olarak değiştirterek arsivliyorum.
Sormak istediğim 2 soru var birincisi downloads klasöründe çok sayıda mkv dosyası olsaydı hepsi adına ayrı ayrı klasör oluşturup içine atmam gerekse nasıl bir kod kullanmam gerekirdi?
ikincisi arsiv klasöründe aynı adla klasör varsa hata vermeden hazır olan klasörün içine ilgili dosyalar atılabilirmi?
tekrar teşekkürler saygılar.
Kullanıcı avatarı
yunus788
 
Kayıt: 22 Arl 2019 18:44
Meslek: textil
Yaş: 42
İleti: 7
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: istanbul

Cevap: Dosya adıyla klasör oluştur, dosyaları o klasöre at,

İleti#6)  Miraç CAN » 16 Ekm 2020 11:06

Birkaç satır silip, bir de klasör var mı sorgusu ekleyerek kolayca olur tabii ki.
If FSO.GetFolder(FldrDLoad).Files.Count - 1 = 2 Then sorgusu ve End If sorgu sonunu;
FSO.MoveFile FldrDLoad & Application.PathSeparator & "*.jpg", NewFldr & Application.PathSeparator jpg taşıma satırını;
Exit For satırını ;
hatta artık gerekmeyeceği için AutoTime = Now + TimeSerial(0, 0, 10)
Application.OnTime AutoTime, ThisWorkbook.CodeName & ".Arşivle"
otomatik çalıştırma satırlarını da silip,
FSO.CreateFolder NewFldr satırına da yoksa sorgusu ekleyerek:
If Not FSO.FolderExists(NewFldr) Then FSO.CreateFolder NewFldr aşağıda ki gibi olur.
Kod: Tümünü seç
Private Sub TamamınıArşivle()
Dim FSO As Object, DFiles As Object, FldrDLoad$, FldrArch$, NewFldr$
Set FSO = CreateObject("Scripting.FileSystemObject")
FldrDLoad = Environ$("UserProfile") & "\Downloads": FldrArch = "C:\Arşiv"
For Each DFiles In FSO.GetFolder(FldrDLoad).Files
    If FSO.GetExtensionName(DFiles) = "mkv" Then
        NewFldr = FldrArch & Application.PathSeparator & FSO.GetBaseName(DFiles)
        If Not FSO.FolderExists(NewFldr) Then FSO.CreateFolder NewFldr
        DFiles.Move NewFldr & Application.PathSeparator
    End If
Next
End Sub
Kullanıcı avatarı
Miraç CAN
Site Dostu
 
Kayıt: 26 Arl 2016 19:07
Meslek: Harita/Ölçme
Yaş: 39
İleti: 752
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Amasya & Adana

REKLAM
ETA - Excel Konsolide Raporlama
ETA Excel Personel Entegre Raporu

Cevap: Dosya adıyla klasör oluştur, dosyaları o klasöre at,

İleti#7)  yunus788 » 16 Ekm 2020 20:11

Sayın Miraç Can tekrar teşekkürler, bu konudaki yardımlarınızla bir heves geldi ve benzer durum senaryoları için kod çalışmalarına başladım. --)(
Kullanıcı avatarı
yunus788
 
Kayıt: 22 Arl 2019 18:44
Meslek: textil
Yaş: 42
İleti: 7
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: istanbul

Cevap: Dosya adıyla klasör oluştur, dosyaları o klasöre at,

İleti#8)  Miraç CAN » 17 Ekm 2020 08:28

İyi çalışmalar dilerim, kolay gelsin.
Kullanıcı avatarı
Miraç CAN
Site Dostu
 
Kayıt: 26 Arl 2016 19:07
Meslek: Harita/Ölçme
Yaş: 39
İleti: 752
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Amasya & Adana


Forum Genel Makro Soruları

Online Kullanıcılar

Bu forumu görüntüleyenler: Kayıtlı kullanıcı yok ve 1 misafir

Bumerang - Yazarkafe