hücre adresine bağlı dosya taşıma

[oydemir]

İyi günler

Sizlerden dosya tasıma konusunda yardım talep ediyorum.

A sütunda dosyadaki isimleri yazılı pdf ve tif uzantılı dosyalar mevcut.( 125_5-7.tif)

B sütunda kopyalanacak dosyaların yolu var (C:\bul\)

C sütununda taşınacak dosyaların yolu var (C:\YAZ\)

Örnek kopyalanacak adresler farklılık yaratıyor. A sütunludaki 125_5-7.tif dosyasını B sütundaki adresten (C:\bul\ klasöründen) keserek alacak C sütundaki adrese kopyalayacak (C:\YAZ\) bir makroya ihtiyacım var bu şekilde bir makro olabilir mi Teşekkürler

 

[RBozkurt]

Merhaba,

1. makro istediğiniz işlemi yapar,

Sub DosyaTasima_Uzantisiz()

    Dim satir As Long
    Dim sonSatir As Long
    Dim dosyaAdi As String
    Dim kaynakAdres As String
    Dim hedefAdres As String
    Dim tamKaynakYol As String
    Dim tamHedefYol As String
    Dim mevcutDosya As String

    ' Son satırı belirle
    sonSatir = Cells(Rows.Count, 1).End(xlUp).Row
    
    ' İlk satır başlık olduğu için 2. satırdan başla
    For satir = 2 To sonSatir
        ' Dosya adını, kaynak ve hedef adresleri al
        dosyaAdi = Trim(Cells(satir, 1).Value)
        kaynakAdres = Trim(Cells(satir, 2).Value)
        hedefAdres = Trim(Cells(satir, 3).Value)
        
        ' Kaynak ve hedef adresin sonunda ters eğik çizgi yoksa ekle
        If Right(kaynakAdres, 1) <> "\" Then
            kaynakAdres = kaynakAdres & "\"
        End If
        If Right(hedefAdres, 1) <> "\" Then
            hedefAdres = hedefAdres & "\"
        End If
        
        ' Kaynak klasörde bu dosya adına uygun herhangi bir dosya var mı?
        mevcutDosya = Dir(kaynakAdres & dosyaAdi & ".*") ' Herhangi bir uzantıyı bul
        
        ' Eğer dosya bulunursa, tam yolları belirle
        If mevcutDosya <> "" Then
            tamKaynakYol = kaynakAdres & mevcutDosya
            tamHedefYol = hedefAdres & mevcutDosya
            
            ' Dosyayı taşı
            FileCopy tamKaynakYol, tamHedefYol
            Kill tamKaynakYol ' Orijinal dosyayı sil
        Else
            MsgBox "Dosya bulunamadı: " & kaynakAdres & dosyaAdi, vbExclamation
        End If
    Next satir
    
    MsgBox "Dosya taşıma işlemi tamamlandı.", vbInformation

End Sub

2. makroda da HEDEF_2 sütununa yazdığınız klasör yolunu otomatik oluşturarak taşıma işlemini yapar.
Örnek C:\YAZ\ klasörü yerine C:\YAZ\Test dediniz. Test klasörünü oluşturur ve taşır.

Sub DosyaTasima_Uzantisiz_OtomatikKlasorIlk()

    Dim satir As Long
    Dim sonSatir As Long
    Dim dosyaAdi As String
    Dim kaynakAdres As String
    Dim hedefAdres As String
    Dim tamKaynakYol As String
    Dim tamHedefYol As String
    Dim mevcutDosya As String

    ' Son satırı belirle
    sonSatir = Cells(Rows.Count, 1).End(xlUp).Row
    
    ' İlk satır başlık olduğu için 2. satırdan başla
    For satir = 2 To sonSatir
        ' Dosya adını, kaynak ve hedef adresleri al
        dosyaAdi = Trim(Cells(satir, 1).Value)
        kaynakAdres = Trim(Cells(satir, 2).Value)
        hedefAdres = Trim(Cells(satir, 3).Value)
        
        ' Kaynak ve hedef adresin sonunda ters eğik çizgi yoksa ekle
        If Right(kaynakAdres, 1) <> "\" Then
            kaynakAdres = kaynakAdres & "\"
        End If
        If Right(hedefAdres, 1) <> "\" Then
            hedefAdres = hedefAdres & "\"
        End If
        
        ' Hedef klasör mevcut mu? Değilse oluştur
        Call KlasorOlustur(hedefAdres)
        
        ' Kaynak klasörde bu dosya adına uygun herhangi bir dosya var mı?
        mevcutDosya = Dir(kaynakAdres & dosyaAdi & ".*") ' Herhangi bir uzantıyı bul
        
        ' Eğer dosya bulunursa, tam yolları belirle
        If mevcutDosya <> "" Then
            tamKaynakYol = kaynakAdres & mevcutDosya
            tamHedefYol = hedefAdres & mevcutDosya
            
            ' Dosyayı taşı
            FileCopy tamKaynakYol, tamHedefYol
            Kill tamKaynakYol ' Orijinal dosyayı sil
        Else
            MsgBox "Dosya bulunamadı: " & kaynakAdres & dosyaAdi, vbExclamation
        End If
    Next satir
    
    MsgBox "Dosya taşıma işlemi tamamlandı.", vbInformation

End Sub

' Alt klasörleriyle birlikte hedef klasörü oluşturan yardımcı fonksiyon
Sub KlasorOlustur(dizin As String)
    Dim FSO As Object
    Dim klasorDizisi() As String
    Dim i As Long
    Dim mevcutDizin As String

    ' Klasör dizisi ayırıcıya göre böl
    klasorDizisi = Split(dizin, "\")
    
    ' Yavaş yavaş her seviyeyi oluştur
    mevcutDizin = klasorDizisi(0) & "\"
    For i = 1 To UBound(klasorDizisi)
        If klasorDizisi(i) <> "" Then
            mevcutDizin = mevcutDizin & klasorDizisi(i) & "\"
            ' Klasör yoksa oluştur
            If Dir(mevcutDizin, vbDirectory) = "" Then
                MkDir mevcutDizin
            End If
        End If
    Next i
End Sub

 

[oydemir]

teşekkürler harikasınız

 

[volki_112]

İyi günler

Sizlerden dosya tasıma konusunda yardım talep ediyorum.

A sütunda dosyadaki isimleri yazılı pdf ve tif uzantılı dosyalar mevcut.( 125_5-7.tif)

B sütunda kopyalanacak dosyaların yolu var (C:\bul\)

C sütununda taşınacak dosyaların yolu var (C:\YAZ\)

Örnek kopyalanacak adresler farklılık yaratıyor. A sütunludaki 125_5-7.tif dosyasını B sütundaki adresten (C:\bul\ klasöründen) keserek alacak C sütundaki adrese kopyalayacak (C:\YAZ\) bir makroya ihtiyacım var bu şekilde bir makro olabilir mi Teşekkürler

istediğiniz kod. bu kodu çalıştırın istediğiniz işlem olur

Sub DosyaTasima()
    Dim ws As Worksheet
    Dim kaynakDosyaYolu As String
    Dim hedefDosyaYolu As String
    Dim kaynakDosya As String
    Dim i As Long
    Dim sonSatir As Long
    
    ' Aktif sayfayı tanımla
    Set ws = ActiveSheet
    
    ' A sütunundaki son dolu hücreyi bul
    sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Her satırda işlemi tekrarla
    For i = 2 To sonSatir
        ' B sütunundaki dosya yolunu al
        kaynakDosyaYolu = ws.Cells(i, 2).Value ' B sütunundaki dosya yolu
        kaynakDosya = ws.Cells(i, 1).Value ' A sütunundaki dosya adı
        
        ' C sütunundaki hedef dosya yolunu al
        hedefDosyaYolu = ws.Cells(i, 3).Value ' C sütunundaki hedef dosya yolu
        
        ' Dosya taşıma işlemi
        If Dir(kaynakDosyaYolu & "\" & kaynakDosya) <> "" Then
            ' Dosyayı taşı
            Name kaynakDosyaYolu & "\" & kaynakDosya As hedefDosyaYolu & "\" & kaynakDosya
            MsgBox "Dosya başarıyla taşındı: " & kaynakDosya, vbInformation
        Else
            MsgBox "Kaynak dosya bulunamadı: " & kaynakDosya, vbExclamation
        End If
    Next i
End Sub

 

[oydemir]

Teşekkürler

 

[RBozkurt]

teşekkürler harikasınız

Kolay gelsin.