Makro Revize

metin_0606 · 12 Ocak 2021

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

metin_0606 · 12 Ocak 2021

güncel

Korhan Ayhan · 12 Ocak 2021

Bu ikinci klasör yolu ne işe yarayacak?

metin_0606 · 12 Ocak 2021

Korhan Ayhan' Alıntı:
Bu ikinci klasör yolu ne işe yarayacak?

Korhan Hocam Klas1 de belirttiğim klasörde bulamazsa Diğer belirttiğim klasörde arayacak

Korhan Ayhan · 12 Ocak 2021

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 · 12 Ocak 2021

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

metin_0606 · 12 Ocak 2021

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

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 · 12 Ocak 2021

Kopyalamaz çünkü sadece Klas1 isimli klasöre DIR çekilmiş.

Hemen düzeltelim..

Korhan Ayhan · 12 Ocak 2021

#5 nolu mesajımı revize ettim. Tekrar deneyiniz.

metin_0606 · 12 Ocak 2021

Korhan Ayhan' Alıntı:
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 · 13 Ocak 2021

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 · 13 Ocak 2021

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

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 · 13 Ocak 2021

Klasör yollarını kendinize göre düzenlediniz değil mi?

metin_0606 · 13 Ocak 2021

Korhan Ayhan' Alıntı:
Klasör yollarını kendinize göre düzenlediniz değil mi?

Evet Korhan hocam klasör yollarını kendime göre düzenledim

Korhan Ayhan · 13 Ocak 2021

O zaman örnek dosyaları ekleyin bakalım sorun neredeymiş.

metin_0606 · 13 Ocak 2021

Korhan Ayhan' Alıntı:
O zaman örnek dosyaları ekleyin bakalım sorun neredeymiş.

Örnek Dosya

Korhan Ayhan · 13 Ocak 2021

Siz uzantı yazmadan arama yapıyorsunuz.

metin_0606 · 13 Ocak 2021

Korhan Ayhan' Alıntı:
Siz uzantı yazmadan arama yapıyorsunuz.

Anladım korhan hocam benim kendi paylaştığım makroda uzantıyı dikkate almadığı için yazmış olduğunuz makroda aynı mantıkla çalışıyor sanmıştır. Teşekkürler

Korhan Ayhan · 13 Ocak 2021

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 · 13 Ocak 2021

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

Çok teşekkür ederim Korhan hocam zihnine sağlık sağolasın

Makro Revize

metin_0606

metin_0606

Korhan Ayhan

Administrator

metin_0606

Korhan Ayhan

Administrator

metin_0606

metin_0606

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

metin_0606

Korhan Ayhan

Administrator

metin_0606

Korhan Ayhan

Administrator

metin_0606

Korhan Ayhan

Administrator

metin_0606

Ekli dosyalar

Korhan Ayhan

Administrator

metin_0606

Korhan Ayhan

Administrator

metin_0606