Çalışma kitaplarını başka bir dosyaya taşıma

[KARTAL133]

Merhaba Arkadaşlar

Farklı dosyalarda Excel çalışma kitapları var bu dosyalarını yolları bulup kopyalıyacağımı yanın evet yazılanları başka bir yere taşımak istiyorum.
Dosya yerleri bulma kodunu yaptım ancak nasıl taşıma yapma komudunu bulamadım.
Yardımcı olmanızı rica ederim.

 

[Korhan Ayhan]

Özünde çalışma kitabı ve farklı dosya aynı şeyler. Siz tam olarak neyi nereye taşımak istiyorsunuz?

 

[KARTAL133]

Merhaba Hocam

Dosya yollarını buraya ekleyip c kolununda yes yazılanları başka bir dosyaya kopyalamak istiyorum.
dosyaların taşımak için "yes" veya "No" kısmını ben elle manual olarak yazacam.

 

[Korhan Ayhan]

A2 hücresinde yazan adreste tam olarak ne var?

 

[KARTAL133]

B2 de bulunan excel çalışma kitabının nerede olduğunu göstermektedir.

 

[Korhan Ayhan]

"Başka bir dosya" olarak ifade ettiğiniz dosyanız nerede bulunuyor? Bu bir excel dosyası mı?

 

[KARTAL133]

Örneğin 10 tane farklı klasör var. içleinden farklı excel "isimleride farklı" çalışma kitabı bulunmaktadır. "c" kolanuna "yes" yazdıklarımı başka bir Dosya içine kopyalamasını istiyorum.
koypalanacak dosya adı sabit bir dosya adı olacak Dosya Adı "Deneme_Dosyası" yes yazdıklarım çalışma kitapları A ve b Birleştirekek yazılan yollara göre "Denem_Dosyası" içine kopyalama yapacak

 

[KARTAL133]

Umarım anlata bilmişimdir.

 

[MusaPEKEL]

Örneğin 10 tane farklı klasör var. içleinden farklı excel "isimleride farklı" çalışma kitabı bulunmaktadır. "c" kolanuna "yes" yazdıklarımı başka bir Dosya içine kopyalamasını istiyorum.
koypalanacak dosya adı sabit bir dosya adı olacak Dosya Adı "Deneme_Dosyası" yes yazdıklarım çalışma kitapları A ve b Birleştirekek yazılan yollara göre "Denem_Dosyası" içine kopyalama yapacak

Sub Kopyala()
    Dim dosyaAdi As String
    dosyaAdi = "Deneme_Dosyası.xlsx" ' Hedef dosyanın adı
    
    Dim dosyaYolu As String
    dosyaYolu = ThisWorkbook.Path & "\" & dosyaAdi ' Hedef dosyanın tam yolu
    
    Dim hedefKitap As Workbook
    On Error Resume Next
    Set hedefKitap = Workbooks(dosyaAdi)
    On Error GoTo 0
    
    ' Hedef dosya yoksa oluştur
    If hedefKitap Is Nothing Then
        Set hedefKitap = Workbooks.Add
        hedefKitap.SaveAs dosyaYolu
    End If
    
    Dim satir As Long
    Dim hedefSatir As Long
    Dim ws As Worksheet
    
    ' Her bir çalışma kitabını kontrol et
    For Each ws In ThisWorkbook.Sheets
        ' C sütununda "Yes" olan satırları kontrol et
        For satir = 1 To ws.Cells(Rows.Count, "C").End(xlUp).Row
            If UCase(ws.Cells(satir, "C").Value) = "YES" Then
                ' Hedef dosyada bir sonraki boş satıra kopyala
                hedefSatir = hedefKitap.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1
                ' Veriyi kopyala
                ws.Rows(satir).Copy Destination:=hedefKitap.Sheets(1).Rows(hedefSatir)
            End If
        Next satir
    Next ws
    
    hedefKitap.Close SaveChanges:=True ' Hedef dosyayı kaydet ve kapat
End Sub

 

[KARTAL133]

Merhaba Musa Hocam

elinize sağlık istediğim bu değil

ekteki dosya yazdım bir baka bilirmisiniz.

 

[Necdet]

Merhaba Hocam

Dosya yollarını buraya ekleyip c kolununda yes yazılanları başka bir dosyaya kopyalamak istiyorum.
dosyaların taşımak için "yes" veya "No" kısmını ben elle manual olarak yazacam.

Hiç pratik değilsiniz.
Ben olsam herhangi bir değer yazarım, aktarılmayacaklara ise hiç dokunmam. Zaman Önemli ve Değerli dolayısıyla C sütununda boş olmayan tüm dosyalara ne yapılacaksa yapılır.
Ayrıca Yes'i yes te yazarsanız kodda bunu kontrol etmeniz gerekir. Yanlışlıkla Yed yazdınız o aynen kalır

 

[KARTAL133]

Merhaba Hocam tamam nasıl daha hızlı olacaksa böyle olsun
bu iş benim 4 saattımı alıyor
onu hiç bile düşünmedim acıkcası

 

[KARTAL133]

Hocam bu işlemi yapıla bilir mi

 

[Necdet]

Merhaba,
Dosyalar aktarılacak mı , yani mevcut dizinden diğer dizine ,yoksa kopyası mı çıkartılacak.
eğer dosyataşınacaksa, taşıdığı dizinde aynı dosya olup olmadığını kontrol etmedim, o da edilebilinir.
Aşağıdaki kodları deneyiniz.
Aktarılacak dizini Sayfa2 E1 sütununa yazınız.

Sub DosyaKesAktar()

' Tools / References / Microsoft Scripting Runtime
' Seçili Olmalı

Dim fso As New FileSystemObject
Dim yol As String
Dim i   As Long
Dim arr As Variant
Dim adt As Integer
Dim ds1 As String
Dim ds2 As String

yol = Sayfa2.Range("E1") & Application.PathSeparator
arr = Sayfa2.Range("A1").CurrentRegion.Value

For i = 2 To UBound(arr, 1)
    If Not arr(i, 3) = "" And Not arr(i, 3) = "Aktarıldı" Then
        ds1 = arr(i, 1) & Application.PathSeparator & arr(i, 2)
        ds2 = yol & arr(i, 2)
        fso.CopyFile ds1, ds2
'        fso.MoveFile ds1, ds2
        arr(i, 3) = "Aktarıldı"
        adt = adt + 1
    End If
Next i

Sayfa2.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr

MsgBox adt & " DOSYA AKTARILDI...."

End Sub

 

[KARTAL133]

Merhaba,
Dosyalar aktarılacak mı , yani mevcut dizinden diğer dizine ,yoksa kopyası mı çıkartılacak.
eğer dosyataşınacaksa, taşıdığı dizinde aynı dosya olup olmadığını kontrol etmedim, o da edilebilinir.
Aşağıdaki kodları deneyiniz.
Aktarılacak dizini Sayfa2 E1 sütununa yazınız.

Sub DosyaKesAktar()

' Tools / References / Microsoft Scripting Runtime
' Seçili Olmalı

Dim fso As New FileSystemObject
Dim yol As String
Dim i   As Long
Dim arr As Variant
Dim adt As Integer

yol = Sayfa2.Range("E1") & Application.PathSeparator
arr = Sayfa2.Range("A1").CurrentRegion.Value

For i = 2 To UBound(arr, 1)
    If Not arr(i, 3) = "" And Not arr(i, 3) = "Aktarıldı" Then
        arr(i, 1) = Replace(arr(i, 1) & "\", "\\", "\") & arr(i, 2)
        fso.MoveFile arr(i, 1), yol & arr(i, 2)
        arr(i, 3) = "Aktarıldı"
        adt = adt + 1
    End If
    Debug.Print i
Next i

Sayfa2.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
MsgBox adt & " DOSYA AKTARILDI...."
End Sub

Merhaba Hocam

Kopyalama yapacak

 

[KARTAL133]

Merhaba Hocam

hata verdi

 

[Necdet]

Referansı eklediniz mi? kodarın başında açıklama olarak koymuşum.

Kopyalama için

fso.MoveFile yerine fso.CopyFile kullanın.

 

[KARTAL133]

Merhaba

Yeni yaptım dikkat etmemiştim
dosya aktarımı yapamdı

 

[Necdet]

Merhaba,
Ben kodları deneyin gönderdim.
Aktarım yapmıyorsa dosya yolu ya da dosya adını kontrol ediniz
Bunlar doğru ise yine bakarız.

 

[KARTAL133]

kontrol ettim dosya yollunda sorun yok Hocam