Excel İle Dosya Kopyalama

[ruzzher]

Merhaba
Excelde bir dosyayı farklı bir klasörden bir başka klasöre kopyalamak istiyorum.
Verileri şu şekilde olacak
A hücrelerinde dosya adı yazılacak Örnek "Ahmet".
B hücresinde dosyanın aranacağı yer "C:\Users\***\Desktop\YeniKlasör\"
C hücresinde ise kopyalacağı yer olacak "C:\Users\***\Desktop\Kopya\"

Not: 10.000 yakın arama yapmasını istiyorum tek tuşla

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Copy_File()
    Dim Rng As Range, My_File As String
   
    For Each Rng In Range("A2:C" & Cells(Rows.Count, 1).End(3).Row).Columns(1).Cells
        If Rng.Value <> "" And Rng.Offset(, 1) <> "" And Rng.Offset(, 2) <> "" Then
            My_File = Dir(Rng.Offset(, 1) & "*" & Rng.Value & "*")
            If My_File <> "" Then
                VBA.CreateObject("Scripting.FileSystemObject").CopyFile Rng.Offset(, 1) & My_File, Rng.Offset(, 2) & My_File
            End If
        End If
    Next
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[ruzzher]

Deneyiniz.

Option Explicit

Sub Copy_File()
    Dim Rng As Range, My_File As String
   
    For Each Rng In Range("A2:C" & Cells(Rows.Count, 1).End(3).Row).Columns(1)
        If Rng.Value <> "" And Rng.Offset(, 1) <> "" And Rng.Offset(, 2) <> "" Then
            My_File = Dir(Rng.Offset(, 1) & "*" & Rng.Value & "*")
            If My_File <> "" Then
                VBA.CreateObject("Scripting.FileSystemObject").CopyFile Rng.Offset(, 1) & My_File, Rng.Offset(, 2) & My_File
            End If
        End If
    Next
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

kod çalışmıyor

 

[Korhan Ayhan]

2022 Aralık ayında cevaplanan bir konuya yeni yanıt vermişsiniz...

 

[ruzzher]

tekrardan ihtiyacım var da

2022 Aralık ayında cevaplanan bir konuya yeni yanıt vermişsiniz...

 

[Korhan Ayhan]

Peki önerdiğim kod Aralık ayında çalışmışmıydı.

 

[ruzzher]

hiç hatırlamıyorum

 

[Korhan Ayhan]

Ben büyük ihtimalle deneyerek kodları paylaşmışımdır..

Çalışmıyor demişsiniz. Hata mı veriyor? Hata veriyorsa, hangi satırda hata veriyor?

 

[ruzzher]

Ben büyük ihtimalle deneyerek kodları paylaşmışımdır..

Çalışmıyor demişsiniz. Hata mı veriyor? Hata veriyorsa, hangi satırda hata veriyor?

 

[Korhan Ayhan]

Örnek dosyanız var mı?

 

[ruzzher]

Örnek dosyanız var mı?

 

[Korhan Ayhan]

Bu hata veren örnek dosyanız mı?

 

[ruzzher]

Sub TopluDosyaKopyalaVeAdDegistir()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    
    ' Çalışma sayfasını belirtin
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Sheet1 yerine kullanılan sayfa adını belirtin
    
    ' Son satırı bulun
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Her satır için dosya kopyalama işlemini yapın
    For i = 2 To lastRow ' İlk satır başlık olduğu varsayılarak 2'den başlıyoruz
        Dim dosyaAdi As String
        Dim kaynakKlasor As String
        Dim hedefKlasor As String
        Dim yeniDosyaAdi As String
        Dim sonuc As String
        
        dosyaAdi = ws.Cells(i, "A").Value
        kaynakKlasor = ws.Cells(i, "B").Value
        hedefKlasor = ws.Cells(i, "C").Value
        yeniDosyaAdi = ws.Cells(i, "D").Value ' Yeni dosya adı sütunu (örneğin D sütunu)
        
        If dosyaAdi <> "" And kaynakKlasor <> "" And hedefKlasor <> "" And yeniDosyaAdi <> "" Then
            If Right(kaynakKlasor, 1) <> "\" Then
                kaynakKlasor = kaynakKlasor & "\"
            End If
            
            If Right(hedefKlasor, 1) <> "\" Then
                hedefKlasor = hedefKlasor & "\"
            End If
            
            If Dir(kaynakKlasor & dosyaAdi) <> "" Then
                FileCopy kaynakKlasor & dosyaAdi, hedefKlasor & yeniDosyaAdi
                sonuc = "Kopyalandı"
            Else
                sonuc = "Bulunamadı"
            End If
        Else
            sonuc = "Eksik bilgi"
        End If
        
        ws.Cells(i, "E").Value = sonuc ' Sonuçları E sütununda (veya istediğiniz sütunda) raporlayın
    Next i
    
    MsgBox "Toplu dosya kopyalama ve ad değiştirme işlemi tamamlandı!"
End Sub

doğru bu dur

 

[Korhan Ayhan]

#2 nolu mesajımdaki kodda küçük bir revize yaptım. Dilerseniz deneyebilirsiniz.