Makro Revize

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
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Bu ikinci klasör yolu ne işe yarayacak?
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
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
 
Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
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ı.
 
Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
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

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ı.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Kopyalamaz çünkü sadece Klas1 isimli klasöre DIR çekilmiş.

Hemen düzeltelim..
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
#5 nolu mesajımı revize ettim. Tekrar deneyiniz.
 
Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Kopyalamaz çünkü sadece Klas1 isimli klasöre DIR çekilmiş.

Hemen düzeltelim..
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ı
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
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
 
Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
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 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.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Klasör yollarını kendinize göre düzenlediniz değil mi?
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
O zaman örnek dosyaları ekleyin bakalım sorun neredeymiş.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Siz uzantı yazmadan arama yapıyorsunuz.
 
Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
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
 
Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
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
Çok teşekkür ederim Korhan hocam zihnine sağlık sağolasın
 
Üst