• DİKKAT

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

Makro Revize

M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Kod: 
Sub KOPYALA()

    Dim A As Object, dsy As String
    Dim Klas1 As String
    Dim Klas2 As String
    Klas1 = "C:\GKK_PDF\" 'VERİ ALINACAK KLASÖR
    Klas2 = "C:\KLASOR1\" 'VERİ KOPYALANACAK KLASÖR
    Set A = CreateObject("scripting.filesystemobject")
If Not A.FolderExists(Klas2) Then MkDir Klas2
For i = 2 To Cells(Rows.Count, "A").End(3).Row
If Trim(Cells(i, "A").Value) <> "" Then
dsy = Dir(Klas1 & Trim(Cells(i, "A").Value) & "*.*", vbDirectory)
'dsy = Trim(Cells(i, "A").Value) & ".pdf" 'sadece tc kimlik no
If A.FileExists(Klas1 & dsy) = True Then
A.copyFile Source:=Klas1 & dsy, Destination:=Klas2 & "\" ' PDF KOPYALAMA
Cells(i, "A").Interior.ColorIndex = 4
Else
Cells(i, "A").Interior.ColorIndex = 3
End If: End If
Next
MsgBox "işlem tamam"
End Sub
Değerli üstatlar bu makro ile A sütununa yazdığım tc kimlik numaraları ile Klas1 deki tanımlı klasörden Klas2 deki tanımlı klasöre dosya kopyalıyorum. Yapmak istediğim Klas1 de tanımlı klasörün yanına ikinci bir klasör yolu daha eklemek. Yardımlarınız için şimdiden teşekkürler
 
Bu ikinci klasör yolu ne işe yarayacak?
 
Deneyiniz.

C++: 
Sub KOPYALA()
    Dim A As Object, dsy As String
    Dim Klas1 As String
    Dim Klas2 As String
    Dim Klas3 As String
    
    Klas1 = "C:\GKK_PDF\" 'VERİ ALINACAK KLASÖR
    Klas2 = "C:\DENEME\" 'VERİ ALINACAK KLASÖR
    Klas3 = "C:\KLASOR1\" 'VERİ KOPYALANACAK KLASÖR
    
    Set A = CreateObject("scripting.filesystemobject")

    If Not A.FolderExists(Klas3) Then MkDir Kla3
    
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
        If Trim(Cells(i, "A").Value) <> "" Then
            dsy = Dir(Klas1 & Trim(Cells(i, "A").Value) & "*.*", vbDirectory)
            'dsy = Trim(Cells(i, "A").Value) & ".pdf" 'sadece tc kimlik no
            If A.FileExists(Klas1 & dsy) = True Then
                A.copyFile Source:=Klas1 & dsy, Destination:=Klas3 & "\" ' PDF KOPYALAMA
                Cells(i, "A").Interior.ColorIndex = 4
            Else
                Cells(i, "A").Interior.ColorIndex = 3
            End If
        
            dsy = Dir(Klas2 & Trim(Cells(i, "A").Value) & "*.*", vbDirectory)
            'dsy = Trim(Cells(i, "A").Value) & ".pdf" 'sadece tc kimlik no
            If A.FileExists(Klas2 & dsy) = True Then
                A.copyFile Source:=Klas2 & dsy, Destination:=Klas3 & "\" ' PDF KOPYALAMA
                Cells(i, "A").Interior.ColorIndex = 4
            Else
                Cells(i, "A").Interior.ColorIndex = 3
            End If
        End If
    Next
    
    MsgBox "işlem tamam"
End Sub
 
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
Sub KOPYALA()
    Dim A As Object, dsy As String
    Dim Klas1 As String
    Dim Klas2 As String
    Dim Klas3 As String
   
    Klas1 = "C:\GKK_PDF\" 'VERİ ALINACAK KLASÖR
    Klas2 = "C:\DENEME\" 'VERİ ALINACAK KLASÖR
    Klas3 = "C:\KLASOR1\" 'VERİ KOPYALANACAK KLASÖR
   
    Set A = CreateObject("scripting.filesystemobject")

    If Not A.FolderExists(Klas3) Then MkDir Kla3
   
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
        If Trim(Cells(i, "A").Value) <> "" Then
            dsy = Dir(Klas1 & Trim(Cells(i, "A").Value) & "*.*", vbDirectory)
            'dsy = Trim(Cells(i, "A").Value) & ".pdf" 'sadece tc kimlik no
            If A.FileExists(Klas1 & dsy) = True Then
                A.copyFile Source:=Klas1 & dsy, Destination:=Klas3 & "\" ' PDF KOPYALAMA
                Cells(i, "A").Interior.ColorIndex = 4
            ElseIf A.FileExists(Klas2 & dsy) = True Then
                A.copyFile Source:=Klas2 & dsy, Destination:=Klas3 & "\" ' PDF KOPYALAMA
                Cells(i, "A").Interior.ColorIndex = 4
            Else
                Cells(i, "A").Interior.ColorIndex = 3
            End If
        End If
    Next
   
    MsgBox "işlem tamam"
End Sub
[/QUOT
Korhan Hocam A Sütununa deneme amaçlı 2 adet TC kimlik numarası yazıp (Bu TC kimlik numarası ile isimlendirilmiş dosyalardan biri GKK_PDF diğeri DENEME klasörünün içinde) makroyu çalıştırdığımda GKK_PDF klasöründeki dosyayı bulup KLASOR1 isimli klasöre kopyaladı ancak DENEME isimli klasördeki dosyayı kopyalamadı.
Genişletmek için tıkla ...
 
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
Sub KOPYALA()
    Dim A As Object, dsy As String
    Dim Klas1 As String
    Dim Klas2 As String
    Dim Klas3 As String
   
    Klas1 = "C:\GKK_PDF\" 'VERİ ALINACAK KLASÖR
    Klas2 = "C:\DENEME\" 'VERİ ALINACAK KLASÖR
    Klas3 = "C:\KLASOR1\" 'VERİ KOPYALANACAK KLASÖR
   
    Set A = CreateObject("scripting.filesystemobject")

    If Not A.FolderExists(Klas3) Then MkDir Kla3
   
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
        If Trim(Cells(i, "A").Value) <> "" Then
            dsy = Dir(Klas1 & Trim(Cells(i, "A").Value) & "*.*", vbDirectory)
            'dsy = Trim(Cells(i, "A").Value) & ".pdf" 'sadece tc kimlik no
            If A.FileExists(Klas1 & dsy) = True Then
                A.copyFile Source:=Klas1 & dsy, Destination:=Klas3 & "\" ' PDF KOPYALAMA
                Cells(i, "A").Interior.ColorIndex = 4
            ElseIf A.FileExists(Klas2 & dsy) = True Then
                A.copyFile Source:=Klas2 & dsy, Destination:=Klas3 & "\" ' PDF KOPYALAMA
                Cells(i, "A").Interior.ColorIndex = 4
            Else
                Cells(i, "A").Interior.ColorIndex = 3
            End If
        End If
    Next
   
    MsgBox "işlem tamam"
End Sub
Genişletmek için tıkla ...


Korhan Hocam A Sütununa deneme amaçlı 2 adet TC kimlik numarası yazıp (Bu TC kimlik numarası ile isimlendirilmiş dosyalardan biri GKK_PDF diğeri DENEME klasörünün içinde) makroyu çalıştırdığımda GKK_PDF klasöründeki dosyayı bulup KLASOR1 isimli klasöre kopyaladı ancak DENEME isimli klasördeki dosyayı kopyalamadı.
 
Kopyalamaz çünkü sadece Klas1 isimli klasöre DIR çekilmiş.

Hemen düzeltelim..
 
#5 nolu mesajımı revize ettim. Tekrar deneyiniz.
 
Korhan Ayhan' Alıntı:
Kopyalamaz çünkü sadece Klas1 isimli klasöre DIR çekilmiş.

Hemen düzeltelim..
Genişletmek için tıkla ...
Korhan hocam öncelikle çok teşekkür ederim her zaman ki gibi yine hızır gibi yetiştiniz. Makro şuan istenileni yaptı. Sadece Color index kısmı olması gerektiği gibi çalışmadı. Normalde her iki dosyayıda bulup kopyaladığı için A sütunundaki her iki TC kimlik numarasınında yeşil dolgu olması gerekirken Klas1 de bulduğunu kırmızı dolgu yaptı diğerini yeşil dolgu yaptı
 
Kodu revize ettim. Deneyiniz.

C++: 
Option Explicit

Sub Dosya_Kopyala()
    Dim FSO As Object, X As Long, Dosya As String, Say As Long
    Dim Klasor_1 As String, Klasor_2 As String, Klasor_3 As String
    
    Klasor_1 = "C:\Test1\"
    Klasor_2 = "C:\Test2\"
    Klasor_3 = "C:\Test3\"
    
    Set FSO = CreateObject("Scripting.FileSystemObject")

    If Not FSO.FolderExists(Klasor_3) Then MkDir Klasor_3
    
    Range("A2:A" & Rows.Count).Interior.Color = xlNone
    
    For X = 2 To Cells(Rows.Count, "A").End(3).Row
        Dosya = Trim(Cells(X, "A").Value)
        If Dosya <> "" Then
            If FSO.FileExists(Klasor_1 & Dosya) = True Then
                FSO.CopyFile Source:=Klasor_1 & Dosya, Destination:=Klasor_3
                Cells(X, "A").Interior.ColorIndex = 4
                Say = Say + 1
            ElseIf FSO.FileExists(Klasor_2 & Dosya) = True Then
                FSO.CopyFile Source:=Klasor_2 & Dosya, Destination:=Klasor_3
                Cells(X, "A").Interior.ColorIndex = 4
                Say = Say + 1
            Else
                Cells(X, "A").Interior.ColorIndex = 3
            End If
        End If
    Next
    
    Set FSO = Nothing
    
    If Say > 0 Then
        MsgBox Say & " adet dosya kopyalanmıştır"
    Else
        MsgBox "Kopyalanacak dosya bulunamadı!", vbExclamation
    End If
End Sub
 
Korhan Ayhan' Alıntı:
Kodu revize ettim. Deneyiniz.

C++: 
Option Explicit

Sub Dosya_Kopyala()
    Dim FSO As Object, X As Long, Dosya As String, Say As Long
    Dim Klasor_1 As String, Klasor_2 As String, Klasor_3 As String
   
    Klasor_1 = "C:\Test1\"
    Klasor_2 = "C:\Test2\"
    Klasor_3 = "C:\Test3\"
   
    Set FSO = CreateObject("Scripting.FileSystemObject")

    If Not FSO.FolderExists(Klasor_3) Then MkDir Klasor_3
   
    Range("A2:A" & Rows.Count).Interior.Color = xlNone
   
    For X = 2 To Cells(Rows.Count, "A").End(3).Row
        Dosya = Trim(Cells(X, "A").Value)
        If Dosya <> "" Then
            If FSO.FileExists(Klasor_1 & Dosya) = True Then
                FSO.CopyFile Source:=Klasor_1 & Dosya, Destination:=Klasor_3
                Cells(X, "A").Interior.ColorIndex = 4
                Say = Say + 1
            ElseIf FSO.FileExists(Klasor_2 & Dosya) = True Then
                FSO.CopyFile Source:=Klasor_2 & Dosya, Destination:=Klasor_3
                Cells(X, "A").Interior.ColorIndex = 4
                Say = Say + 1
            Else
                Cells(X, "A").Interior.ColorIndex = 3
            End If
        End If
    Next
   
    Set FSO = Nothing
   
    If Say > 0 Then
        MsgBox Say & " adet dosya kopyalanmıştır"
    Else
        MsgBox "Kopyalanacak dosya bulunamadı!", vbExclamation
    End If
End Sub
Genişletmek için tıkla ...
Korhan hocam makroyu denedim next satırında hata verdi sanırım End İf eksikti onu ekledim makro hata vermeden çalıştı. Ancak dosya olduğu halde kopyalama yapmadı, Kopyalanacak dosya bulunamadı uyarısı verdi. İsterseniz örnek dosya paylaşabilirim.
 
Klasör yollarını kendinize göre düzenlediniz değil mi?
 
O zaman örnek dosyaları ekleyin bakalım sorun neredeymiş.
 
Siz uzantı yazmadan arama yapıyorsunuz.
 
Aşağıdaki gibi denerseniz uzantı yazmanıza gerek kalmaz.

C++: 
Option Explicit

Sub Dosya_Kopyala()
    Dim FSO As Object, X As Long, Dosya As String, Say As Long
    Dim Klasor_1 As String, Klasor_2 As String, Klasor_3 As String
    
    Klasor_1 = "C:\Users\mert\Desktop\ARŞİV 1\"
    Klasor_2 = "C:\Users\mert\Desktop\ARŞİV 2\"
    Klasor_3 = "C:\Users\mert\Desktop\DENEME\"
    
    Set FSO = CreateObject("Scripting.FileSystemObject")

    If Not FSO.FolderExists(Klasor_3) Then MkDir Klasor_3
    
    Range("A2:A" & Rows.Count).Interior.Color = xlNone
    
    For X = 2 To Cells(Rows.Count, "A").End(3).Row
        Dosya = Trim(Cells(X, "A").Value)
        If Dir(Klasor_1 & Dosya & "*.*") <> "" Then
            Dosya = Dir(Klasor_1 & Dosya & "*.*")
        End If
        If Dir(Klasor_2 & Dosya & "*.*") <> "" Then
            Dosya = Dir(Klasor_2 & Dosya & "*.*")
        End If
        
        If Dosya <> "" Then
            If FSO.FileExists(Klasor_1 & Dosya) = True Then
                FSO.CopyFile Source:=Klasor_1 & Dosya, Destination:=Klasor_3
                Cells(X, "A").Interior.ColorIndex = 4
                Say = Say + 1
            ElseIf FSO.FileExists(Klasor_2 & Dosya) = True Then
                FSO.CopyFile Source:=Klasor_2 & Dosya, Destination:=Klasor_3
                Cells(X, "A").Interior.ColorIndex = 4
                Say = Say + 1
            Else
                Cells(X, "A").Interior.ColorIndex = 3
            End If
        End If
    Next
    
    Set FSO = Nothing
    
    If Say > 0 Then
        MsgBox Say & " adet dosya kopyalanmıştır"
    Else
        MsgBox "Kopyalanacak dosya bulunamadı!", vbExclamation
    End If
End Sub
 
Korhan Ayhan' Alıntı:
Aşağıdaki gibi denerseniz uzantı yazmanıza gerek kalmaz.

C++: 
Option Explicit

Sub Dosya_Kopyala()
    Dim FSO As Object, X As Long, Dosya As String, Say As Long
    Dim Klasor_1 As String, Klasor_2 As String, Klasor_3 As String
   
    Klasor_1 = "C:\Users\mert\Desktop\ARŞİV 1\"
    Klasor_2 = "C:\Users\mert\Desktop\ARŞİV 2\"
    Klasor_3 = "C:\Users\mert\Desktop\DENEME\"
   
    Set FSO = CreateObject("Scripting.FileSystemObject")

    If Not FSO.FolderExists(Klasor_3) Then MkDir Klasor_3
   
    Range("A2:A" & Rows.Count).Interior.Color = xlNone
   
    For X = 2 To Cells(Rows.Count, "A").End(3).Row
        Dosya = Trim(Cells(X, "A").Value)
        If Dir(Klasor_1 & Dosya & "*.*") <> "" Then
            Dosya = Dir(Klasor_1 & Dosya & "*.*")
        End If
        If Dir(Klasor_2 & Dosya & "*.*") <> "" Then
            Dosya = Dir(Klasor_2 & Dosya & "*.*")
        End If
       
        If Dosya <> "" Then
            If FSO.FileExists(Klasor_1 & Dosya) = True Then
                FSO.CopyFile Source:=Klasor_1 & Dosya, Destination:=Klasor_3
                Cells(X, "A").Interior.ColorIndex = 4
                Say = Say + 1
            ElseIf FSO.FileExists(Klasor_2 & Dosya) = True Then
                FSO.CopyFile Source:=Klasor_2 & Dosya, Destination:=Klasor_3
                Cells(X, "A").Interior.ColorIndex = 4
                Say = Say + 1
            Else
                Cells(X, "A").Interior.ColorIndex = 3
            End If
        End If
    Next
   
    Set FSO = Nothing
   
    If Say > 0 Then
        MsgBox Say & " adet dosya kopyalanmıştır"
    Else
        MsgBox "Kopyalanacak dosya bulunamadı!", vbExclamation
    End If
End Sub
Genişletmek için tıkla ...
Çok teşekkür ederim Korhan hocam zihnine sağlık sağolasın
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst