• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Makro ile klasörden klasöre yada emaili dosya kopyalama.

mustilem23' Alıntı:
Halit Bey sorunu buldum ,

İzin ile alakalı değildir ,bizim hedef klasörümüzün alt klasörleri mevcut,aşağıdaki gibi.bu yoldaki bir refarans kodunu arattım buldu.

\\durmaarge\ARGE_DAGITIM\SERI_MAKINELER\1050
\\durmaarge\ARGE_DAGITIM\SERI_MAKINELER\1125

yaklasık bunun gibi 200 alt klasör var benim refarans numaralarım bu alt klasörlerin için de ,
malum her seferinde bu klasörleri yol gösteremeyiz ana klasörden arama yapabilecek şekilde makro düzenlememiz mümkün müdür.

ana klasör.
\\durmaarge\ARGE_DAGITIM\SERI_MAKINELER
Genişletmek için tıkla ...

kod:

Kod: 
Sub dasyakopyala()

Kaynak = "\\durmaarge\ARGE_DAGITIM\SERI_MAKINELER"
Liste (Kaynak)
MsgBox "işlem tamam"
End Sub

Private Sub Liste(yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")
hedefKlasor = "C:\Users\MDOGRU\Desktop\satınalma\"
ekle = ""
If Right(yol, 1) <> "\" Then ekle = "\"
veriKlasor = yol & ekle

On Error Resume Next
For i = 2 To [a65536].End(3).Row
Dosya = veriKlasor & Cells(i, 1).Value & ".pdf"
Cells(i, 1).Interior.ColorIndex = xlNone
If fL.FileExists(Dosya) = True Then
fL.CopyFile Dosya, hedefKlasor & Cells(i, 1).Value & ".pdf"
Else
Cells(i, 1).Interior.ColorIndex = 3
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

End Sub
 
halit Bey ,

süper oldu çalışıyor fakat ,

10 refarans kodunu 5 dakikada bulabiliyor.
excel lsitemiz de bulamadıklarını kırmızı olarak işaretliyordu fakat şuan tüm satırları kırmızı işaretliyor.

ve birde aşağıda resim de bahsetmek istediğim bir konu var ,işaretli referans nosunun görüldüğü gibi 2 seceneği var bu bir daha revizyon olursa 3 4 olacak şekide ilerleyecek bu 8032300100000A referansa çıkan tüm resimleri de kopyalaması mümkün müdür ?

8032300100000A.pdf
8032300100000A (2).PDF


http://www.resimupload.net.tr/image.php?di=KCA2
 
Bek anlamadım bunu ama aşağıdaki kodu bir deneyin kod bulduğu dosyaları kırmızı olarak renklendirecektir.

Kod: 
Sub dasyakopyala()
son = [a65536].End(3).Row
Range("a1:a" & son).Interior.ColorIndex = xlNone
Kaynak = "\\durmaarge\ARGE_DAGITIM\SERI_MAKINELER"
Liste (Kaynak)
MsgBox "işlem tamam"
End Sub

Private Sub Liste(yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")
hedefKlasor = "C:\Users\MDOGRU\Desktop\satınalma\"
ekle = ""
If Right(yol, 1) <> "\" Then ekle = "\"
veriKlasor = yol & ekle

On Error Resume Next
For i = 2 To [a65536].End(3).Row
Dosya = veriKlasor & Cells(i, 1).Value & ".pdf"
If Cells(i, 1).Interior.ColorIndex <> 3 Then
If fL.FileExists(Dosya) = True Then
fL.CopyFile Dosya, hedefKlasor & Cells(i, 1).Value & ".pdf"
Cells(i, 1).Interior.ColorIndex = 3
End If
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

End Sub
 
halit bey ekledim kırmızı işaretli yeri fakat aşağıdaki gibi bir hata veriyor.

Run-time error '1004'
Method 'Range'of object'_Global' failed
 
halit Bey elinize sağlık çok güzel oldu zamanlama problemide giderilmiş.

Tek eksik olarak aşağıdaki sorunum kaldı ,

örnek verecek olur isek 8032300100000A.pdf dosyasını veri klasörün de aynı kalsörün içerisine ekleyebiliyorlar revizyon için ozaman windovs yeni eklenen pdf e 8032300100000A (2).PDF bir isim adı altında kaydediyor bir tane daha eklenir ise 8032300100000A (3).PDF oluyor anlatmak istediğim.

biz excel tablosuna 8032300100000A yazdığımız da 8032300100000A.pdf ve 8032300100000A (2).PDF 3 4 5 6 isiminde olan diğer dosyalarıda kopyalatabilmemiz mümkün müdür .


8032300100000A.PDF
8032300100000A (2).PDF

8032300100000A yazdığımda klasöre sorguladığımda kaç adet dosya çıkıyorsa hepsini kopyalamak istiyorum
http://www.resimupload.net.tr/image.php?di=KCA2
 
mustilem23' Alıntı:
halit Bey elinize sağlık çok güzel oldu zamanlama problemide giderilmiş.

Tek eksik olarak aşağıdaki sorunum kaldı ,

örnek verecek olur isek 8032300100000A.pdf dosyasını veri klasörün de aynı kalsörün içerisine ekleyebiliyorlar revizyon için ozaman windovs yeni eklenen pdf e 8032300100000A (2).PDF bir isim adı altında kaydediyor bir tane daha eklenir ise 8032300100000A (3).PDF oluyor anlatmak istediğim.

biz excel tablosuna 8032300100000A yazdığımız da 8032300100000A.pdf ve 8032300100000A (2).PDF 3 4 5 6 isiminde olan diğer dosyalarıda kopyalatabilmemiz mümkün müdür .


8032300100000A.PDF
8032300100000A (2).PDF

8032300100000A yazdığımda klasöre sorguladığımda kaç adet dosya çıkıyorsa hepsini kopyalamak istiyorum
http://www.resimupload.net.tr/image.php?di=KCA2
Genişletmek için tıkla ...

kod:

Kod: 
Sub dasyakopyala()
son = [a65536].End(3).Row
Range("a1:a" & son).Interior.ColorIndex = xlNone
Kaynak = "\\durmaarge\ARGE_DAGITIM\SERI_MAKINELER"

Liste (Kaynak)
MsgBox "işlem tamam"

End Sub
Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")
hedefKlasor = "C:\Users\MDOGRU\Desktop\satınalma\"
If Right(yol, 1) <> "\" Then ekle = "\"

For Each Dosya In fL.GetFolder(yol).Files
aranan = fL.GetBaseName(Dosya)

For i = 2 To [a65536].End(3).Row
bulunan = Cells(i, 1).Value
If Mid(aranan, 1, Len(bulunan)) = Mid(bulunan, 1, Len(bulunan)) Then
fL.CopyFile Dosya, hedefKlasor & aranan & ".pdf"
Cells(i, 1).Interior.ColorIndex = 3
End If
Next

Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

End Sub
 
ilginiz için çok teşekkürler iyi günler dilerim.
 
halit3' Alıntı:
Kod ağ durumuna göre ve bilgisayarın hızına göre Kaynak klasörün (alt klasörler dahil) tarama yaparak istenen dosya adını bularak kapyalama yapıyor.
Genişletmek için tıkla ...

Halit bey,
konu ile alakalı olduğundan ben de bir yardımınızı rica edeceğim.

numaralar ile kaydedilmiş 10 resim var.
ben excelimde yazan numaraların jpg olan resimlerini ayrı bir klasöre almak istiyorum. Basit bir makro ile yardımcı olabilir misiniz?
(aslında 60 bin kayıt var, ben 3500 tane seçeceğim ama mantığı anlamak için basitleştirdim.)


Örnek.
klasörde 1,2,3,4,5,6,7,9,10.jpg olarak 10 dosya var.
Excelde a1 sütununda 1,3,5,7,9 yazıyor,
sadece bu dosyaları kaynak klasörden hedef klasöre kopyalamak istiyorum.

Saygılarımla
 
Son düzenleme:
Teşekkür

Bu konu benim çok zamanımı alıyordu. kaynak sürücüden dosyaları tek tek ara tam deneme şansı bulamadım fakat ufak bir deneme yaptım çalışıyor. teşekkür.. elinize sağlık
 
Klasörden klasöre dosya kopyalama

Merhaba Arkadaşlar,
Office 2016 kullanıyorum.Ekli dosyadaki txt uzantılı dosyaları a klasöründen b klasörüne kopyalayamadım.
yardımlarınız için şimdiden teşekkür ederim.
 

Ekli dosyalar

Bu kodu bir deneyin

Kod: 
Dim hedefKlasor
Private Sub CommandButton1_Click()
Klasor = ThisWorkbook.Path
hedefKlasor = Klasor & "\b\"
Liste (Klasor)
MsgBox "işlem tamam !", vbInformation, "DİKKAT"

End Sub
Private Sub Liste(Klasor As String)

Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each dosya In fL.GetFolder(Klasor).Files

If Mid(dosya.Name, 1, 2) <> "~$" Then
If fL.GetExtensionName(dosya) = "txt" Then
i = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("a1:a65000")) + 1
Cells(i, 1).Value = dosya
If CreateObject("Scripting.FileSystemObject").FileExists(dosya) = True Then
fL.CopyFile dosya, hedefKlasor & dosya.Name
End If

End If
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(Klasor).SubFolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
Halit Hocam,
Mevcut kodlarla A klasörü ve alt klasörleri içinde veya A klasörü dışında ne kadar txt uzantılı dosya varsa B klasörüne kopyalıyor.
olmasını istediğim ise:
A klasörü ve alt klasörlerin içindeki txt uzantılı dosyalardan Excel de a1:a65000 aralığına yolunu belirteceğim dosyalardan istediğimi B klasörüne kopyalamak istiyorum.
Yardımlarınız için çok teşekkür ederim
 
steppe' Alıntı:
Halit Hocam,
Mevcut kodlarla A klasörü ve alt klasörleri içinde veya A klasörü dışında ne kadar txt uzantılı dosya varsa B klasörüne kopyalıyor.
olmasını istediğim ise:
A klasörü ve alt klasörlerin içindeki txt uzantılı dosyalardan Excel de a1:a65000 aralığına yolunu belirteceğim dosyalardan istediğimi B klasörüne kopyalamak istiyorum.
Yardımlarınız için çok teşekkür ederim
Genişletmek için tıkla ...

Kod:

Kod: 
Private Sub CommandButton2_Click()
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
hedefKlasor = ThisWorkbook.Path & "\b\"
For i = 1 To Cells(Rows.Count, "A").End(3).Row
Dosya = Cells(i, 1).Value
If fL.GetExtensionName(Dosya) = "txt" Then
If fL.FileExists(Dosya) = True Then
fL.CopyFile Dosya, hedefKlasor & fL.GetFileName(Dosya)
End If
End If
Next i
End Sub

Private Sub CommandButton1_Click()
veriKlasor = ThisWorkbook.Path & "\a\"
Liste (veriKlasor)
MsgBox "işlem tamam !", vbInformation, "DİKKAT"
End Sub

Private Sub Liste(Klasor As String)

Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.GetFolder(Klasor).Files
If Mid(Dosya.Name, 1, 2) <> "~$" Then
If fL.GetExtensionName(Dosya) = "txt" Then
i = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("a1:a65000")) + 1
Cells(i, 1).Value = Dosya

End If
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(Klasor).SubFolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
Halit Hocam,
Yardımlarınız için çok teşekkür ederim...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst