On Error İkinci Hatada Çalışmıyor

[peaceseller]

Merhaba,excel sayfasında isimlerini listelediğim dosyaları bir klasörde bulup başka bir klasöre kopyalayan bir makro yazdım. Fakat listede bulunup kaynak klasörde bulunmayan bir dosyaya geldiğinde on error komutu ile bulunamayan dosyaları ayrı bir sütunda listelemek istediğim zaman,bulamadığı ilk dosyayı listeye ekliyor yani düzgün çalışıyor, ikinci bulamadığı dosyada on error çalışmayıp filecopy satırında "file not found" hatasını veriyor. Yardımcı olursanız sevinirim.

Private Sub CommandButton3_Click()

Set s1 = Sheets("Resim")
k = 0
DosyaSayısı = Application.CountA(s1.Columns(2)) - 1

For i = 1 To DosyaSayısı
On Error GoTo 10
Source = TextBox1.Text & "\" & s1.Cells(i + 4, 2) & ".tif"
Target = TextBox2.Text & "\" & s1.Cells(i + 4, 2) & ".tif"
FileCopy Source, Target
k = k + 1
yuzde = Round((k / DosyaSayısı) * 100, 0)
s1.Cells(2, 9).Value = "%" & yuzde & " kopyalandı"
GoTo 20

10 BDosyaSayısı = Application.CountA(s1.Columns(4))
s1.Cells(i + 2 + BDosyaSayısı, 4) = s1.Cells(i + 4, 2)

20 Next i

s1.Cells(2, 9).Value = BDosyaSayısı & " dosya bulunamadı"

End Sub

 

[Levent Menteşoğlu]

Hata komutu yerine dosyanın ilgili klasörde olup olmadığına bakan bir satır ilave etmek sorunu çözecektir. Kodunuzu aşağıdaki ile değiştirerek deneyin.

[vb:1:88837b3f4f]Private Sub CommandButton3_Click()
Set s1 = Sheets("Resim")
k = 0
DosyaSayısı = Application.CountA(s1.Columns(2)) - 1
For i = 1 To DosyaSayısı
Source = TextBox1.Text & "\" & s1.Cells(i + 4, 2) & ".tif"
deg = CreateObject("Scripting.FileSystemObject").FileExists(Source)
If deg = False Then GoTo 10
Target = TextBox2.Text & "\" & s1.Cells(i + 4, 2) & ".tif"
FileCopy Source, Target
k = k + 1
yuzde = Round((k / DosyaSayısı) * 100, 0)
s1.Cells(2, 9).Value = "%" & yuzde & " kopyalandı"
GoTo 20
10 BDosyaSayısı = Application.CountA(s1.Columns(4))
s1.Cells(i + 2 + BDosyaSayısı, 4) = s1.Cells(i + 4, 2)
20 Next i
s1.Cells(2, 9).Value = BDosyaSayısı & " dosya bulunamadı"
End Sub
[/vb:1:88837b3f4f]

 

[peaceseller]

Teşekkürler,çalıştı.Siz olmasanız biz bu işi zor öğreneceğiz.

 

[peaceseller]

Dosya isminin bir kısmını ihmal etmek

Merhaba,

Daha önce,Excel sayfasında isimlerini listelediğim dosyaları belirtilen klasör diyalog kutusundan seçilen klasörden bulup, yine klasör diyalog kutusundan seçilen bir klasöre kopyalayan bir makro ile ilgili sorular sormuştum. Kodu alıntı olarak aşağıda.

Source = TextBox1.Text & "\" & s1.Cells(i + 4, 2) & ".tif"

satırında
"TextBox1.Text" : klasör konumunu belirtiyor (C:\Belgelerim)
"s1.Cells(i + 4, 2)" : listeden alınan dosya ismini belirtiyor
".tif" : dosyalar tif formatında

benim istediğim; (kullandığım dosya isimleri şu şekilde "81.12540.2112@a.tif", yani noktalarla birlikte 13 haneli rakam grubunun sonuna "@a" , "@b" gibi 2 hane daha ekleniyor) dosyaları son 2 hane hariç ilk 13 hanesi ile listeye gireyim,makro bu dosyaları sadece ilk 13 hanesine bakarak, bu ismi 13 hane ile başlayan dosyaları bularak kopyalasın,son 2 haneyi dikkate almasın. Son iki hane yokmuş gibi çalışsın istiyorum.

Yardımcı olabilirseniz memnun olurum.

Hata komutu yerine dosyanın ilgili klasörde olup olmadığına bakan bir satır ilave etmek sorunu çözecektir. Kodunuzu aşağıdaki ile değiştirerek deneyin.

[vb:1:9cd50f2128]Private Sub CommandButton3_Click()
Set s1 = Sheets("Resim")
k = 0
DosyaSayısı = Application.CountA(s1.Columns(2)) - 1
For i = 1 To DosyaSayısı
Source = TextBox1.Text & "\" & s1.Cells(i + 4, 2) & ".tif"
deg = CreateObject("Scripting.FileSystemObject").FileExists(Source)
If deg = False Then GoTo 10
Target = TextBox2.Text & "\" & s1.Cells(i + 4, 2) & ".tif"
FileCopy Source, Target
k = k + 1
yuzde = Round((k / DosyaSayısı) * 100, 0)
s1.Cells(2, 9).Value = "%" & yuzde & " kopyalandı"
GoTo 20
10 BDosyaSayısı = Application.CountA(s1.Columns(4))
s1.Cells(i + 2 + BDosyaSayısı, 4) = s1.Cells(i + 4, 2)
20 Next i
s1.Cells(2, 9).Value = BDosyaSayısı & " dosya bulunamadı"
End Sub
[/vb:1:9cd50f2128]