Klasörde dosya kontrolü.

vardar07 · 19 Ocak 2017

Merhaba arkadaşlar. Aşağıdaki kod ile istenilen klasöre dosya ekleyebiliyorum.
Aynı klasör içine tekrar dosya kayıt ederken aynı isimle dosya varsa isim sonuna takı ekleyerek kayıt yapmak için dosya kontrolü ve takı ekleme olayını nasıl çözebiliriz.

Kod:

Sub Dosya()
Set s1 = ThisWorkbook.Sheets("veri")
Set Ss = ThisWorkbook.Sheets("Sablon")
son = Sayfa1.Range("L" & Rows.Count).End(3).Row
For i = 1 To son
deg = Sayfa2.Cells(i, "L").Value 'Kayıt yapılacak klasörün adı
deg1 = Sayfa2.Cells(i, "I").Value 'Kayıt yapılacak dosyanın adı

Yol = ThisWorkbook.Path & "\" & deg & "\"
 
 Workbooks.Add

Set s2 = ActiveWorkbook.Sheets("Sayfa1")
 Ss.Cells.Copy s2.Range("a1")
 s2.SaveAs Filename:=Yol & deg1
   ActiveWorkbook.Save
    ActiveWindow.Close

Next

End Sub

systran · 19 Ocak 2017

klasörün sonuna eklenecek takı rastgele, elle veya benzersiz seçilecek bir veri mi?
çünkü bunun da önceden oluşturulmadığı kontrol edilmesi gerekir.
örn: güncel tarih ve saat bilgisinden oluşan sayısal değer olabilir.

Kod:

Sub deneme()
    klasör = "Test"
    yol = "C:\" & klasör & "\"
    sonuc = Dir(yol)
    If sonuc = Empty Then
        MsgBox yol & vbNewLine & "klasör yoktu, oluşturulacak."
        MkDir (yol)
    Else
        MsgBox "klasör mevcut, sonuna takı eklenecek, yeni klasör oluşturulacak."
        takı = "_xxx"
        yeni_isim = klasör & takı
        yeni_yol = "C:\" & yeni_isim
        MkDir (yeni_yol)   'bununda kontrol edilmesi gerek.
    End If
End Sub

ilave:
şu kod ile döngü içinde sırayla TEST_1, TEST_2, ... şeklinde klasör oluşturmaya çalışır. varsa sayı 1 artar, yeni isimli klasör var mı tekrar tekrar kontrol eder.

Kod:

Sub deneme()
    i = 0
    
    Do
    i = i + 1
    klasör = "Test" & "_" & i
    yol = "C:\" & klasör
    Loop Until mevcut(yol) = False
    MkDir (yol)
    
End Sub
Function mevcut(ByVal yol As String) As Boolean

Dim sonuc As String
sonuc = Dir(yol, vbDirectory)
If sonuc = Empty Then
  'klasör yok
  mevcut = False
Else
  mevcut = True
End If
End Function

vardar07 · 19 Ocak 2017

systran' Alıntı:
klasörün sonuna eklenecek takı rastgele, elle veya benzersiz seçilecek bir veri mi?
çünkü bunun da önceden oluşturulmadığı kontrol edilmesi gerekir.

Sayın systran ilginize teşekkürler. Size zahmet verdim. Dosya diye yazacağıma Klasör diye yazmışım. Klasör içindeki dosyayı(Çalışma kitabını) kontrol edip varsa takılı yoksa takısız ekleyecek. Hatamdan dolayı özür dilerim.

halit3 · 19 Ocak 2017

Bu kodu bir dene

Kod:

Sub Dosya()
Set s1 = ThisWorkbook.Sheets("veri")
Set Ss = ThisWorkbook.Sheets("Sablon")
son = Sayfa1.Range("L" & Rows.Count).End(3).Row
For i = 1 To son
deg = Sayfa2.Cells(i, "L").Value 'Kayıt yapılacak klasörün adı
deg1 = Sayfa2.Cells(i, "I").Value 'Kayıt yapılacak dosyanın adı

yol = ThisWorkbook.Path & "\" & deg & "\"
[COLOR="red"]say = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files.Count + 1
[/COLOR]
Workbooks.Add

Set s2 = ActiveWorkbook.Sheets("Sayfa1")
Ss.Cells.Copy s2.Range("a1")

[COLOR="red"]If CreateObject("Scripting.FileSystemObject").FileExists(yol & deg1) = False Then[/COLOR]
s2.SaveAs Filename:=yol & deg1
[COLOR="Red"]Else
s2.SaveAs Filename:=yol & say & deg1
End If
[/COLOR]
ActiveWorkbook.Save
ActiveWindow.Close

Next

End Sub

vardar07 · 19 Ocak 2017

halit3' Alıntı:

Bu kodu bir dene

Kod:

Sub Dosya()
Set s1 = ThisWorkbook.Sheets("veri")
Set Ss = ThisWorkbook.Sheets("Sablon")
son = Sayfa1.Range("L" & Rows.Count).End(3).Row
For i = 1 To son
deg = Sayfa2.Cells(i, "L").Value 'Kayıt yapılacak klasörün adı
deg1 = Sayfa2.Cells(i, "I").Value 'Kayıt yapılacak dosyanın adı

yol = ThisWorkbook.Path & "\" & deg & "\"
say = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files.Count 

Workbooks.Add

Set s2 = ActiveWorkbook.Sheets("Sayfa1")
Ss.Cells.Copy s2.Range("a1")

If CreateObject("Scripting.FileSystemObject").FileExists(yol & deg1 [COLOR="Red"]& ".xlsx"[/COLOR]) = False Then
s2.SaveAs Filename:=yol & deg1
Else
s2.SaveAs Filename:=yol  & deg1 & say +1
End If

ActiveWorkbook.Save
ActiveWindow.Close

Next

End Sub

Elinize sağlık Kırmızılı yeri ekleyince süper oldu. Çok teşekkürler.
say = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files.Count ile deg1'i saydırabilirsek dahada güzel olacak. Farklı dosyaisminede takı ekliyor.

vardar07 · 20 Ocak 2017

Güncel. Sihirli bir dokunuşa ihtiyaç var.

vardar07 · 22 Ocak 2017

Konu günceldir.

k::

Korhan Ayhan · 22 Ocak 2017

Kod içindeki diğer bilgilerin doğru olduğunu varsayarsak aşağıdaki kod işinizi görecektir.

Kod:

Sub Dosya()
    Set s1 = ThisWorkbook.Sheets("veri")
    Set Ss = ThisWorkbook.Sheets("Sablon")
    son = Sayfa1.Range("L" & Rows.Count).End(3).Row
    
    For i = 1 To son
        deg = Sayfa2.Cells(i, "L").Value 'Kayıt yapılacak klasörün adı
        deg1 = Sayfa2.Cells(i, "I").Value 'Kayıt yapılacak dosyanın adı
        
        Yol = ThisWorkbook.Path & "\" & deg & "\"
        Kontrol = Dir(Yol & deg1 & "*.*")
        
        While Kontrol <> ""
            Say = Say + 1
            Kontrol = Dir
        Wend
        
        Workbooks.Add
        
        Set s2 = ActiveWorkbook.Sheets("Sayfa1")
        Ss.Cells.Copy s2.Range("a1")
        
        If CreateObject("Scripting.FileSystemObject").FileExists(Yol & deg1) = False Then
        s2.SaveAs Filename:=Yol & deg1
        Else
        s2.SaveAs Filename:=Yol & Say & deg1
        End If
        
        ActiveWorkbook.Save
        ActiveWindow.Close
    Next
End Sub

vardar07 · 22 Ocak 2017

Korhan Bey çok teşekkür ederim. Küçük bir değişiklikle işlem tamam.Belki birine daha lazım olur. Elinize sağlık.

Kod:

Sub Dosya()
    Set S1 = ThisWorkbook.Sheets("veri")
    Set Ss = ThisWorkbook.Sheets("Sablon")
    son = S1.Range("L" & Rows.Count).End(3).Row
    Application.DisplayAlerts = False
    For i = 1 To son
        deg = S1.Cells(i, "L").Value 'Kayıt yapılacak klasörün adı
        deg1 = S1.Cells(i, "I").Value 'Kayıt yapılacak dosyanın adı
        yol = ThisWorkbook.Path & "\" & deg & "\"

        Kontrol = Dir(yol & deg1 & "*.*")        
         While Kontrol <> ""
            say = say + 1
            Kontrol = Dir
        Wend

        Workbooks.Add
        Set s2 = ActiveWorkbook.Sheets("Sayfa1")
        Ss.Cells.Copy s2.Range("a1")

        [COLOR="Red"]If say > 0 Then
      s2.SaveAs Filename:=yol & deg1 & "-" & say
        say = 0
        Else
        s2.SaveAs Filename:=yol & deg1
        End If[/COLOR]

        ActiveWorkbook.Save
        ActiveWindow.Close
    Next
   Application.DisplayAlerts = True
End Sub

halit3 · 23 Ocak 2017

Evde net olmadığından hafta sonları cevap yazmıyorum gerçi çözüm bulmuşsunuz
Alternatif olsun.

Kod:

Sub Dosya()

Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")

Set s1 = ThisWorkbook.Sheets("veri")
Set Ss = ThisWorkbook.Sheets("Sablon")
son = Sayfa1.Range("L" & rows.Count).End(3).Row
For i = 1 To son
Deg = Sayfa2.Cells(i, "L").Value 'Kayıt yapılacak klasörün adı
Dosya = fs.GetBaseName(Sayfa2.Cells(i, "I").Value) 'Kayıt yapılacak dosyanın adı
uzanti = fs.GetExtensionName(Dosya) 'dosya uzantısını kendisi buluyor


Yol = ThisWorkbook.Path & "\" & Deg & "\"

say1 = 0
For Each dosya1 In fs.GetFolder(Yol).Files

If uzanti = fs.GetExtensionName(Dosya) And Mid(dosya1.Name, 1, Len(Dosya)) = Dosya Then
say1 = say1 + 1
End If

Next

If say1 = 0 Then
say1 = ""
End If


Workbooks.Add

Set s2 = ActiveWorkbook.Sheets("Sayfa1")
Ss.Cells.Copy s2.Range("a1")

If fs.FileExists(Yol & Dosya & uzanti) = False Then
s2.SaveAs Filename:=Yol & Dosya & uzanti
Else
s2.SaveAs Filename:=Yol & Dosya & " " & say1 & uzanti
End If

ActiveWorkbook.Save
ActiveWindow.Close

Next

End Sub

vardar07 · 23 Ocak 2017

Halit Bey emeğinize çok teşekkür ederim. Yeni kod daha ayrıntılı olmuş. Lakin dosyada yine tek dosya oluşturup ikincisi için değiştirme onayı istiyor. Evet dersek önceki dosyayı güncelliyor. Biz ise mesela Alaylı klasörüne kayıt yapılacak TC si ayrı 4 adet KADİR DEMİR olması ama 1 tane oluyor. Örnek dosya ekte mevcut.

halit3 · 23 Ocak 2017

Bu kodu bir dene kod verileri liste sayfasından alıyor.

Kod:

Sub Dosya_yap()
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")

Set Ss = ThisWorkbook.Sheets("Sablon")

For i = 2 To ThisWorkbook.Sheets("Liste").Range("B" & Rows.Count).End(3).Row

klsor = ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Liste").Cells(i, "e")
If CreateObject("Scripting.FileSystemObject").FolderExists(klsor) = False Then
MkDir klsor
End If


Dosya = Trim(ThisWorkbook.Sheets("Liste").Cells(i, "b") & " " & ThisWorkbook.Sheets("Liste").Cells(i, "c")) 'Kayıt yapılacak dosyanın adı
uzanti = "xlsx"

Workbooks.Add

yer = ActiveWorkbook.Name

Set s2 = ActiveWorkbook.Sheets("Sayfa1")
Ss.Cells.Copy s2.Range("a1")

say1 = 0
For Each dosya1 In fs.GetFolder(klsor).Files
If uzanti = fs.GetExtensionName(dosya1) And Mid(dosya1.Name, 1, Len(Dosya)) = Dosya Then
say1 = say1 + 1
End If

Next

If say1 = 0 Then
say1 = ""
End If

ActiveWorkbook.SaveAs klsor & "\" & Dosya & " " & say1 & "." & uzanti
ActiveWorkbook.Close False

Next

End Sub

halit3 · 23 Ocak 2017

vardar07' Alıntı:
Halit Bey emeğinize çok teşekkür ederim. Yeni kod daha ayrıntılı olmuş. Lakin dosyada yine tek dosya oluşturup ikincisi için değiştirme onayı istiyor. Evet dersek önceki dosyayı güncelliyor. Biz ise mesela Alaylı klasörüne kayıt yapılacak TC si ayrı 4 adet KADİR DEMİR olması ama 1 tane oluyor. Örnek dosya ekte mevcut.

Bu kod bu mesaj için yazıldı

Kod:

Sub Dosya_yap() '2-Klasör Oluşturma
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")

Set S1 = ThisWorkbook.Sheets("veri")
Set Ss = ThisWorkbook.Sheets("Sablon")
son = S1.Range("B" & Rows.Count).End(3).Row
For i = 1 To son
Deg = S1.Cells(i, "E").Value 'Kayıt yapılacak klasörün adı
Dosya = fs.GetBaseName(S1.Cells(i, "C").Value) 'Kayıt yapılacak dosyanın adı
uzanti = "xlsx"
Yol = ThisWorkbook.Path & "\" & Deg & "\"

Workbooks.Add

yer = ActiveWorkbook.Name

Set s2 = ActiveWorkbook.Sheets("Sayfa1")
Ss.Cells.Copy s2.Range("a1")

say1 = 0
For Each dosya1 In fs.GetFolder(Yol).Files

If uzanti = fs.GetExtensionName(dosya1) And Mid(dosya1.Name, 1, Len(Dosya)) = Dosya Then
say1 = say1 + 1
End If

Next

If say1 = 0 Then
say1 = ""
End If

s2.SaveAs Filename:=Yol & Dosya & " " & say1 & "." & uzanti
ActiveWindow.Close

Next

End Sub

vardar07 · 23 Ocak 2017

halit3' Alıntı:
Bu kod bu mesaj için yazıldı

Halit Bey ne diyeyim, bir önceki mesajda Klasör yaratma koduna gerek kalmadan işlem yapıyor artı avantajı var eksi tarafı aynı kişiye birden fazla dosya açıyordu . Bu kod için diyecek tek şey taş gediğine kondu. Elinize kolunuza sağlık. Klavyeniz takılmasın.Çok teşekkürler. Konu burada sona ermiştir.

Klasörde dosya kontrolü.

vardar07

Destek Ekibi

systran

Destek Ekibi

vardar07

Destek Ekibi

halit3

Uzman

vardar07

Destek Ekibi

vardar07

Destek Ekibi

vardar07

Destek Ekibi

Korhan Ayhan

Administrator

vardar07

Destek Ekibi

Ekli dosyalar

halit3

Uzman

vardar07

Destek Ekibi

Ekli dosyalar

halit3

Uzman

halit3

Uzman

vardar07

Destek Ekibi