Aktif klasördeki dosyayı çoğaltmak

[k0081]

Merhaba arkadaşlar;

aktif klasördeki dosyayı, sayı girerek (inputbox ile) aynı klasör içinde nasıl çoğaltabiliriz ?

örnek ;

Aktif klasör : deneme.pdf

Kaç adet olacak : 5

deneme1.pdf
deneme2.pdf
deneme3.pdf
deneme4.pdf
deneme5.pdf

Not: dosya her zaman pdf değildir. örnek olarak verilmiştir.

yardımcı arkadaşa şimdiden teşekkürler.

 

[Asri]

B1 e kaç adet olacağını yazın.

Aktif dosyanın bulunduğu yerdeki "dosya" klasöründe işlemleri yapar.
Klasörde birden fazla dosya var ise yada klasör boş ise işlem yapmaz.

Dim dosyaadi, dosyaismi, dosyauzantisi As String

Sub kopyala()
   kaynak = ActiveWorkbook.Path & "\dosya\"
   hedef = ActiveWorkbook.Path & "\dosya\"
   
   Set evn = CreateObject("scripting.filesystemobject")
   Set klasor = evn.getfolder(kaynak)
   If klasor.Files.Count > 1 Then
      MsgBox ("Kaynak klasörde birden fazla dosya var. Kopyalama yapılamaz")
      Exit Sub
   End If
  
   If klasor.Files.Count = 0 Then
      MsgBox ("Kaynak klasörde dosya bulunamadı. Kopyalama yapılamaz")
      Exit Sub
   End If
   
   For Each dosya In klasor.Files
       dosyaadi = dosya.Name
       Call isim_uzanti
   Next
   For i = 1 To Cells(1, 2).Value
      kaynakdosya = kaynak & dosyaadi
      hedefdosya = hedef & dosyaismi & i & dosyauzantisi      
      FileCopy kaynakdosya, hedefdosya
   Next i
    Kill kaynakdosya
End Sub
 
Sub isim_uzanti()
  dosyauzantisi = ""
  For i = Len(dosyaadi) To 1 Step -1
     harf = Mid(dosyaadi, i, 1)
     If harf = "." Then
        dosyaismi = Mid(dosyaadi, 1, i - 1)
        dosyauzantisi = Mid(dosyaadi, i, Len(dosyaadi))
        Exit For
     End If
  Next i
End Sub

 

[k0081]

asri;


Hocam kodu çalıştırdım. şöyle bir durum var;

dosyalara 1 , 2 , 3 4 .. şeklinde isim veriyor.

benim amacım orjinal dosya adına ekleme yapması.

orjinal dosya : deneme.pdf

deneme1.pdf
deneme2.pdf
deneme3.pdf gibi...

bir de uzantıyı almıyor.. yani kopyalananlar uzantısız. bunlarda orjinal uzantı ne ise , o olmalı.

bunların dışında Tamamdır.. Teşekkür ederim.

 

[chngrcn]

klasör seçenekleri menüsünden , görünüm sekmesinde

"bilinen dosya türleri için uzantıları gizle" opsiyonundaki çentiğini kaldırdınız mı? aksi halde dosyaların uzantılarını göremezsiniz.. hayırlı geceler..

 

[k0081]

Onu biliyorum hocam. Bu onunla ilgili bir durum değil.. Teşekkürler

 

[Asri]

asri;


Hocam kodu çalıştırdım. şöyle bir durum var;

dosyalara 1 , 2 , 3 4 .. şeklinde isim veriyor.

benim amacım orjinal dosya adına ekleme yapması.

orjinal dosya : deneme.pdf

deneme1.pdf
deneme2.pdf
deneme3.pdf gibi...

bir de uzantıyı almıyor.. yani kopyalananlar uzantısız. bunlarda orjinal uzantı ne ise , o olmalı.

bunların dışında Tamamdır.. Teşekkür ederim.

İlk mesajımda kodlar güncellendi.

en son aşamada kaynak dosya sil eklendi.
Uzantılar ile ilgili bir problem yok. Herhangi bir değişiklik yapılmadı.

Program uzantı tespit etmek için dosya adında en sondan geriye doğru . nokta arıyor bulduğunda ismi ve uzantısını ayırıyor.

 

[Orion1]

Program uzantı tespit etmek için dosya adında en sondan geriye doğru . nokta arıyor bulduğunda ismi ve uzantısını ayırıyor.

Uzantı bulmak için kod aşağıdadır.

Sub Uzantı_İsmi()
Dim ds, f
Set ds = CreateObject("Scripting.FileSystemObject")
f = ds.GetExtensionName("D:\ExcelÖrnekleri\Soru.xls")
MsgBox f
End Sub

 

[Asri]

Uzantı bulmak için kod aşağıdadır.

Sub Uzantı_İsmi()
Dim ds, f
Set ds = CreateObject("Scripting.FileSystemObject")
f = ds.GetExtensionName("D:\ExcelÖrnekleri\Soru.xls")
MsgBox f
End Sub

Kod için teşekkür ederim.

Bu yömtemde bir eksiklik var mı?

Sub isim_uzanti()
  dosyauzantisi = ""
  For i = Len(dosyaadi) To 1 Step -1
     harf = Mid(dosyaadi, i, 1)
     If harf = "." Then
        dosyaismi = Mid(dosyaadi, 1, i - 1)
        dosyauzantisi = Mid(dosyaadi, i, Len(dosyaadi))
        Exit For
     End If
  Next i
End Sub

 

[Orion1]

dosyaismi = Mid(dosyaadi, 1, i - 1)

buradaki 1 başlangıç karakterini gösteriyor.sanırım yanlış.
dosya uzantıları için benim verdiğim kodu kullanınız.

 

[Asri]

dosyaismi = Mid(dosyaadi, 1, i - 1)

buradaki 1 başlangıç karakterini gösteriyor.sanırım yanlış.
dosya uzantıları için benim verdiğim kodu kullanınız.

Bir yanlış anlama var sanrım.

en son noktayı tespit ettikten sonra,
Bu kod ile dosya adını uzantısız alıyorum. Bu isme daha sonra 1,2,3 gibi rakamlar ekleyip dosya uzantısı ile birleştiyorum.

        dosyaismi = Mid(dosyaadi, 1, i - 1)

Bu kod ile de sadece uzantıyı alıyorum.

   dosyauzantisi = Mid(dosyaadi, i, Len(dosyaadi))

 

[k0081]

İlk mesajımda kodlar güncellendi.

en son aşamada kaynak dosya sil eklendi.
Uzantılar ile ilgili bir problem yok. Herhangi bir değişiklik yapılmadı.

Program uzantı tespit etmek için dosya adında en sondan geriye doğru . nokta arıyor bulduğunda ismi ve uzantısını ayırıyor.

Hocam şimdi tamamdır.. Çok Teşekkür ediyorum Elinize-Yüreğinize sağlık.

 

[Asri]

Hocam şimdi tamamdır.. Çok Teşekkür ediyorum Elinize-Yüreğinize sağlık.

Dosya uzantısı ile ilgili problem neydi?
Bir düzeltme yapmamıştım.

 

[k0081]

Orion1;


Hocam cevap için teşekkür ederim. gerekli güncellemeler yapılmış. kod istenen şekilde çalışıyor.

 

[k0081]

Dosya uzantısı ile ilgili problem neydi?
Bir düzeltme yapmamıştım.

Şöyle hocam;

deneme.pdf -> çoğaltılınca --> deneme olarak kalıyordu.. uzantısı yoktu.

******************************

Düzeltme ;

Hocam tamam bi sıkıntı yok ben kodları karıştırmışım... Özür

 

[Orion1]

Bir yanlış anlama var sanrım.

en son noktayı tespit ettikten sonra,
Bu kod ile dosya adını uzantısız alıyorum. Bu isme daha sonra 1,2,3 gibi rakamlar ekleyip dosya uzantısı ile birleştiyorum.

        dosyaismi = Mid(dosyaadi, 1, i - 1)

Bu kod ile de sadece uzantıyı alıyorum.

   dosyauzantisi = Mid(dosyaadi, i, Len(dosyaadi))

Evet bu olur.