• DİKKAT

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

DOSYA TAŞIYAN MAKRO

P

peaceseller

Katılım
25 Temmuz 2006
Mesajlar
19
Merhaba;

Excel sayfasına alt alta dosya isimleri girdiğimi düşünün.Çalıştırıldığında sırayla bu isimli dosyaları belirtilen bir klasör içinde bulacak, kopyalayacak ve yine belirttiğim bir klasöre taşıyacak makroya ihtiyacım var.Hücreleri değişken olarak tanımlayıp Dosya konumu içine değişken olarak gömmeye çalışıyorum,bir türlü yapamadım.Yardım!!! :(
 
Bir örnek dosya ekleyiniz. Kopyalanacak ve taşınacak klasör bilgileri nereden alınacaktır. Birde taşıma kopyalamamı yoksa tamamenmi olacak.
 
dosya kopyalama

İlginiz için çok teşekkür ederim. Ekteki C:\lost.xls\ dosyasında isimleri listelenen .jpeg dosyalarını, C: içindeki "lost" isimli klasör içindeki dosyalar arasından bulup, yine C: sürücüsü altında oluşturulmuş "lostx" adlı klasör içine kopyalayacak.
 
[vb:1:4e13fab866]Sub KOPYALA()
On Error Resume Next
For x = 2 To [A65536].End(3).Row
Source = "c:\lost\" & Cells(x, 1) & ".jpeg"
target = "c:\lostx\" & Cells(x, 1) & ".jpeg"
FileCopy Source, target
Next x
End Sub[/vb:1:4e13fab866]
 
olmuyor

Teşekkürler,fakat bu kod hata vermeden çalışıyor,ama sonuçta lostx içine baktığımda dosyalar kopyalanmamış.
 
Sanırım hata dosya uzantısından kaynaklanıyor. Kod satırlarındaki "jpeg" uzantılarını "jpg" olarak değiştirir misiniz?

Yani;
Source = "c:\lost\" & Cells(x, 1) & ".jpg"
target = "c:\lostx\" & Cells(x, 1) & ".jpg"
şeklinde yazarsanız problem kalmayacaktır.
 
sayın cout(h)ane;

Çektiğim resimleri yıl ve aylara göre ayrı klasörler içinde (2006/ocak 2006/ şubat vb. şekilde) bilgisayara aktarıyorum ve bu resimlerin adlarını excelde bir sayfa üzerinde tutuyorum ve orda süzme veya arama işlemi yaptırdıktan sonra
bu dosyaları ilgili klasörlerinden alıp tek tek başka bir klasöre aktarıyordum. sizin çözüm önerinizi uyguladım gerçekten çok hoş bir çalışma, sizden ricam; örneğinizde olduğu gibi lost klasörünün altındaki diğer klasörleri (klasör adı değişken olabilir - alt alta birkaç klasör olabilir "\lost\2006\nisan\tatil vb) nasıl arattırabilirim.
birkaç deneme yaptım ama başarısız oldum, yardımcı olabilirseniz çok sevinirim.
saygılarımla
 
Sorunuz benim de çok işimi görürdü, tecrübeli arkadaşların yardımını bekliyoruz beraberce :)

Biraz daha açık bir ifade ile:

Source = "c:\lost\" & Cells(x, 1) & ".jpg"

Yukarıdaki kod satırını sadece "c\lost\" klasörü altındaki jpg dosyalarını aratacak şekilde değil de; hem "c\lost\" klasörü, hem de bu klasörün tüm alt klasörlerini (örnek: "c\lost\ocak\", "c\lost\şubat\", "c\lost\şubat\1", "c\lost\şubat\2" gibi) aratacak şekilde nasıl değiştirebiliriz?
 
Bir klasör ve içindeki tüm alt klasörlerde "*xls" uzantılı dosyaları listeleyen aşağıdaki kodu, amacınıza uygun olarak düzenleyebilirsiniz...

Kod: 
Sub Test()
    FileNamesList = CreateFileList("C:\Program Files", "*.xls", True)
    For i = LBound(FileNamesList) To UBound(FileNamesList)
        MyList = MyList & vbCrLf & FileNamesList(i)
    Next
    MsgBox MyList
End Sub
'
Function CreateFileList(MenuPath As String, FileFilter As String, IncludeSubFolder As Boolean) As Variant
    Dim FileList() As String, FileCount As Long
    CreateFileList = ""
    Erase FileList
    With Application.FileSearch
        .NewSearch
        .LookIn = MenuPath
        .Filename = FileFilter
        .LastModified = msoLastModifiedAnyTime
        .SearchSubFolders = IncludeSubFolder
        If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) = 0 Then Exit Function
        ReDim FileList(.FoundFiles.Count)
            For FileCount = 1 To .FoundFiles.Count
                FileList(FileCount) = .FoundFiles(FileCount)
            Next
    End With
    CreateFileList = FileList
    Erase FileList
End Function
 
cevap gönderdiğinizden bu saate kadar uğraşıyorum ve halen yapamadım,
couthane arkadaşım bu kodu uyarlayabildiyse yardım alabilir miyim acaba?
işin içinden çıkacak gibi değilim....
 
Sub KOPYALA()
On Error Resume Next
For x = 2 To [A65536].End(3).Row
Source = "c:\lost\" & Cells(x, 1) & ".jpg"
target = "c:\lostx\" & Cells(x, 1) & ".jpg"
FileCopy Source, target
Next x
End Sub

arkadaşlar bu kod c\lost\dizini altındaki jpg uzantılı dosyaları alıyor
benim yapmaya çalıştığım ve bir türlü başaramadığım ise (haluk beyin kodlarına rağmen), lost dizini altında bulunan diğer alt dizinlerinde taranması
bu konuda yardımlarınızı bekliyorum (kafayı takmış durumdayım)...
 
merhaba;
link vermiş olduğunuz sayfayı dün gece saat 03:30 a kadar inceledim, kendime uyarlamaya çalıştım fakat başarılı olamadım. vermiş olduğunuz linkteki örnekte;
tanımlanan bir dizin (alt dizinler dahil) altındaki dosyaları excel sayfasına aktarmaktadır.
Benim takıldığım konu ise, excel sayfasında A sütununda belirttiğim dosya adlarını tanımladığım dizin (alt dizinler dahil) altında araması ve bulduğunda başka bir (belirttiğim) dizin altına kopyalaması.

Sub KOPYALA()
On Error Resume Next
For x = 2 To [A65536].End(3).Row
Source = "c:\lost\" & Cells(x, 1) & ".jpeg"
target = "c:\lostx\" & Cells(x, 1) & ".jpeg"
FileCopy Source, target
Next x
End Sub

Source = "c:\lost\" & Cells(x, 1) & ".jpeg" (bu satırda sadece "lost" dizini değil, onun altında varolan diğer dizinleri de (isim belirtmeden) almaya çalışıyorum..

:yardim: :yardim: :yardim:
 
Bu şekilde deneyin ...

Kod: 
Sub Test()
    FileNamesList = CreateFileList("C:\lost", "*.jpg", True)
    For x = 2 To [A65536].End(3).Row
        For i = LBound(FileNamesList) To UBound(FileNamesList)
             If (Cells(x, 1) & ".jpg") = Dir(FileNamesList(i)) Then
                FileCopy FileNamesList(i), "C:\lostx\" & Dir(FileNamesList(i))
             End If
        Next
    Next
End Sub
'
Function CreateFileList(MenuPath As String, FileFilter As String, IncludeSubFolder As Boolean) As Variant
    Dim FileList() As String, FileCount As Long
    CreateFileList = ""
    Erase FileList
    With Application.FileSearch
        .NewSearch
        .LookIn = MenuPath
        .Filename = FileFilter
        .LastModified = msoLastModifiedAnyTime
        .SearchSubFolders = IncludeSubFolder
        If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) = 0 Then Exit Function
        ReDim FileList(.FoundFiles.Count)
            For FileCount = 1 To .FoundFiles.Count
                FileList(FileCount) = .FoundFiles(FileCount)
            Next
    End With
    CreateFileList = FileList
    Erase FileList
End Function

Bilgisayarınızda C:\lost\...\...\ ve C:\lostx klasörlerinin olduğundan emin olun.

Ayrıca, sayfada A sütunundaki hücrelerde sadece resim dosyalarının adı olsun, ".jpg" uzantıları yazılı olmayacak.
 
Haluk beye ve diğer arkadaşlara, ilgilerinden ve emeklerinden ötürü teşekkür ederim.
son olarak Haluk beyin göndermiş olduğu kodları denedim, ilk başta yine olmadı fakat üzerinde biraz uğraştım. bu kodlarla jpg - bmp türü resim dosyalarını nedendir taşıyamadım. Dosya uzantılarını doc-xls-txt vb şekilde değiştirdiğimde makro gayet güzel çalıştı.
iki gündür bunun üstünde çalışıyordum ve çıldırmak üzereydim, neyseki haluk beyin sayesinde biraz olsun kurtuldum. jpg uzantılı dosyaları taşıma işini ise başka bir zamana bıraktım artık.
tüm arkadaşlara iyi çalışmalar dilerim
saygılarımla
 
Sayın ozgur2,

Gönderdiğim kodu denemiştim, merak etmeyin ... "*.jpg" uzantılı dosyalar gayet güzel taşınıyor.

Muhtemelen siz, dosyanıza adapte ederken bir hata yapıyorsunuz.

Çalıştığınız dosyayı zip olarak yollarsanız, bakalım...
 
Bu arada aklıma geldi de .... dosya isimlerinde küçük-büyük harf sorunu olabilir.

Bu nedenle, eski Test prosedürü yerine aşağıdakini kullanın. (Dosya isimlerinde Türkçe karakterler varsa, yine sorun olabilir....)

Kod: 
Sub Test()
    FileNamesList = CreateFileList("C:\lost", "*.jpg", True)
    For x = 2 To [A65536].End(3).Row
        For i = LBound(FileNamesList) To UBound(FileNamesList)
             If LCase((Cells(x, 1) & ".jpg")) = LCase(Dir(FileNamesList(i))) Then
                FileCopy FileNamesList(i), "C:\lostx\" & Dir(FileNamesList(i))
             End If
        Next
    Next
End Sub
 
haluk bey;

son gönderdiğiniz kod harika olmuş, ellerinize sağlık. tam pes etmişken sayenizde oldu ve şuan kafam epey rahatladı, bu gece artık rahat bir uyku uyuyabilirim.
çok teşekkürler, isteyen arkadaşlar olursa bu kodları xls dosyası olarak gönderebilrim
herkese iyi çalışmalar dileğiyle....
:mutlu: :mutlu: :mutlu:
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst