Makro Revize

metin_0606

Altın Üye
Katılım
1 Ağustos 2019
Mesajlar
686
Excel Vers. ve Dili
Türkçe 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

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
30,262
Excel Vers. ve Dili
OFFICE 2019 PRO TR
Bu ikinci klasör yolu ne işe yarayacak?
 

Korhan Ayhan

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
30,262
Excel Vers. ve Dili
OFFICE 2019 PRO TR
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
 

metin_0606

Altın Üye
Katılım
1 Ağustos 2019
Mesajlar
686
Excel Vers. ve Dili
Türkçe 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ı.
 

metin_0606

Altın Üye
Katılım
1 Ağustos 2019
Mesajlar
686
Excel Vers. ve Dili
Türkçe 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

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
30,262
Excel Vers. ve Dili
OFFICE 2019 PRO TR
Kopyalamaz çünkü sadece Klas1 isimli klasöre DIR çekilmiş.

Hemen düzeltelim..
 

Korhan Ayhan

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
30,262
Excel Vers. ve Dili
OFFICE 2019 PRO TR
#5 nolu mesajımı revize ettim. Tekrar deneyiniz.
 

metin_0606

Altın Üye
Katılım
1 Ağustos 2019
Mesajlar
686
Excel Vers. ve Dili
Türkçe 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

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
30,262
Excel Vers. ve Dili
OFFICE 2019 PRO TR
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
 

metin_0606

Altın Üye
Katılım
1 Ağustos 2019
Mesajlar
686
Excel Vers. ve Dili
Türkçe 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

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
30,262
Excel Vers. ve Dili
OFFICE 2019 PRO TR
Klasör yollarını kendinize göre düzenlediniz değil mi?
 

Korhan Ayhan

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
30,262
Excel Vers. ve Dili
OFFICE 2019 PRO TR
O zaman örnek dosyaları ekleyin bakalım sorun neredeymiş.
 

Korhan Ayhan

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
30,262
Excel Vers. ve Dili
OFFICE 2019 PRO TR
Siz uzantı yazmadan arama yapıyorsunuz.
 

Korhan Ayhan

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
30,262
Excel Vers. ve Dili
OFFICE 2019 PRO TR
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
 

metin_0606

Altın Üye
Katılım
1 Ağustos 2019
Mesajlar
686
Excel Vers. ve Dili
Türkçe 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