• Web sitemizin SORU-CEVAP bölümünde dosya yüklemek ve dosya indirmek ÜCRETSİZ'dir.
    Gizlilik kapsamında, sadece site yöneticilerimizin ve üyenin kendisinin görebileceği ÜCRETLİ ÖZEL DESTEK alanımız mevcuttur.

Çözüldü Dosya yolu Hk.

mertatakan_3838

Yeni Üye
Kullanıcı
Versiyon
  1. Excel 2016
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Değerli üstatlar iki konu hakkında yardımlarınıza ihtiyacım var. Birinci konu Örnegin evdeki bilgisayarımda Usb bellek içindeki dosyalar E:\ nin içinde görünürken işyerindeki bilgisayara usb takınca D:\ olarak gözüküyor ve kullanmış olduğum makrolarda dosya yolunu buna göre sürekli değiştirmek zorunda kalıyorum. Bunun bir çözümü varmı acaba

İkinci konu:
Dim A As Object, dsy As String
Dim Klas1 As String
Dim Klas2 As String
Klas1 = "C:\Users\mert\Desktop\SGK1\" 'VERİ ALINACAK KLASÖR
Klas2 = "C:\Users\mert\Desktop\DENEME\" 'VERİ TAŞINACAK KLASÖR

Klas1 satırına ikinci bir dosyanın yolunu nasıl tanımlayabiliriz. Örneğin tanımlanacak ikinci dosya yolu: C:\Users\mert\Desktop\SGK2\ Yardımlarınız için şimdiden teşekkürler
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

Çözüm
Sizin kevcut kodunuz da, benim verdiğim çözüm cevabında da veri alınacak klasör kodun en başında,
A sütunundaki TC kimlik numaralarından bağımsız olarak 1 kez tespit ediliyor idi.

Kaynak tespitini, A sütunundaki herbir hücre için ayrı ayrı yapmak için; aşağıdaki kodu kullanın.
Dikkat: kaynak1, kaynak2 ve hedef kasörlerine ilişkin YOL bilgilerini tekrar kontrol etmeyi unutmayın.

C++:
Sub KLASORDEN_KLASORE_BELGE_KOPYALA()
Dim ds As Object
Dim kaynak1 As String, kaynak2 As String
Dim hedef As String, dsy As String

kaynak1 = "C:\Users\admin\Downloads" & "\"
kaynak2 = "C:\Users\admin\Documents\"
hedef = "C:\Users\admin\Downloads\Pivot_Table\"

Set...

Ömer BARAN

Kurucu
Yönetici
Kurucu
Versiyon
  1. Excel 2013
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Şöyle düşünülebilir.

C++:
Sub DOSYA_HANGI_KLASORDE()

Dim ds As Object
Dim XD1 As Boolean, XD2  As Boolean
Dim dsy As String, kls1 As String, kls2 As String
dsy = "XXXXXXXXX.xlsx"
kls1 = ThisWorkbook.Path
kls2 = "C:\Users\admin\Documents"

Set ds = CreateObject("Scripting.FileSystemObject")
XD1 = ds.FileExists(kls1 & "\" & dsy)
XD2 = ds.FileExists(kls2 & "\" & dsy)

If Not XD1 And Not XD2 Then
    MsgBox "İkisinde de yok.": Exit Sub
Else
    If XD1 = True Then yol = kls1
    If XD2 = True Then yol = kls2
End If

'yol bilgisine göre yapılacak işlem kodları'

End Sub
Kod:
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

mertatakan_3838

Yeni Üye
Kullanıcı
Versiyon
  1. Excel 2016
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Şöyle düşünülebilir.

C++:
Sub DOSYA_HANGI_KLASORDE()

Dim ds As Object
Dim XD1 As Boolean, XD2  As Boolean
Dim dsy As String, kls1 As String, kls2 As String
dsy = "XXXXXXXXX.xlsx"
kls1 = ThisWorkbook.Path
kls2 = "C:\Users\admin\Documents"

Set ds = CreateObject("Scripting.FileSystemObject")
XD1 = ds.FileExists(kls1 & "\" & dsy)
XD2 = ds.FileExists(kls2 & "\" & dsy)

If Not XD1 And Not XD2 Then
    MsgBox "İkisinde de yok.": Exit Sub
Else
    If XD1 = True Then yol = kls1
    If XD2 = True Then yol = kls2
End If

'yol bilgisine göre yapılacak işlem kodları'

End Sub
Kod:
Kod:
Sub KOPYALA_SGK()

    Dim A As Object, dsy As String
    Dim Klas1 As String
    Dim Klas2 As String
    Klas1 = "C:\Users\mert\Desktop\SGK1\" 'VERİ ALINACAK KLASÖR
    Klas2 = "C:\Users\mert\Desktop\DENEME\" 'VERİ TAŞINACAK 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
Ömer hocam geri dönüş için öncelikle teşekkür ederim. Makronun tamamını paylaşma gereksinimi duydum. Bu makro ile ben excel sayfasının A sütununa TC kimlik numaraları yazıp Klas1 deki yolunu belirtmiş olduğum klasörde bu TC kimlik numaralarına göre arattırıp eğer dosya varsa Klas2 deki klasörün içine kopyalama yaptırıyorum. Kopyalama yapılan veriler varsa A sütunundaki TC kimlik numaraları yeşil dolgu ile dosya yok ise kırmızı dolgu ile işaretleniyor. Buraya kadar hiç bir sorun yok. Benim bu makroya eklemek istediğim klas1 satırına yanı arama yapılacak klasör yoluna ikinci bir klasör yolu daha eklemek istiyorum.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

Ömer BARAN

Kurucu
Yönetici
Kurucu
Versiyon
  1. Excel 2013
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Yanlış düşünmüyorsam;

C#:
Sub KLASORDEN_KLASORE_BELGE_KOPYALA()

    
Dim ds As Object
Dim kaynak1 As String, kaynak2 As String
Dim hedef As String, dsy As String

kaynak1 = "C:\e-FaturaEdit" & "\"           'KAYNAK KLASÖR SEÇENEK_1
kaynak2 = "C:\Users\admin\Documents\"       'KAYNAK KLASÖR SEÇENEK_2

hedef = "C:\OMER_BARAN_OZEL\"               'HEDEF KLASÖR

Set ds = CreateObject("Scripting.FileSystemObject")

If ds.FolderExists(kaynak1) Then
    kaynak = kaynak1            'kaynak1 KLASÖRÜ VARSA ilgili belge kaynak1 klasöründen kopyalanacak
ElseIf ds.FolderExists(kaynak2) Then
    kaynak = kaynak2            'kaynak1 klasörü yoksa ve kaynak2 KLASÖRÜ VARSA ilgili belge kaynak1 klasöründen kopyalanacak
Else
    MsgBox "Veri ALINACAK iki klasör de YOK!", vbCritical: Exit Sub
End If

If Not ds.FolderExists(hedef) Then
    MsgBox "Veri TAŞINACAK klasör YOK": Exit Sub    'kopyalanan belgenin yapıştırılacağı klasör yoksa işlem yapılmayacak
End If

For i = 2 To Cells(Rows.Count, "A").End(3).Row
    If Trim(Cells(i, "A").Value) <> "" Then
        dsy = Dir(kaynak & Trim(Cells(i, "A").Value) & "*.*", vbDirectory)
        'dsy = Trim(Cells(i, "A").Value) & ".pdf" 'sadece tc kimlik no
        If ds.FileExists(kaynak & dsy) = True Then
            ds.copyFile Source:=kaynak & dsy, Destination:=hedef ' 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
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

mertatakan_3838

Yeni Üye
Kullanıcı
Versiyon
  1. Excel 2016
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Yanlış düşünmüyorsam;

C++:
Sub DOSYA_HANGI_KLASORDE()

Dim ds As Object, a As Object
Dim XD1 As Boolean, XD2  As Boolean
Dim dsy As String, kls1_1 As String, kls1_2 As String
dsy = "08 2016 KBS Puantaj.xls"
kls1_1 = "C:\Users\mert\Desktop\SGK1\"     ' KAYNAK DOSYA İÇİN BİRİNCİ YOL SEÇENEĞİ
kls1_2 = "C:\Users\admin\Documents\"    ' KAYNAK DOSYA İÇİN İKİNCİ SEÇENEĞİ

Klas2 = "C:\Users\mert\Desktop\DENEME\" 'HEDEF KLASÖR

Set ds = CreateObject("Scripting.FileSystemObject")
Set a = CreateObject("Scripting.FileSystemObject")

XD1 = ds.FileExists(kls1_1 & "\" & dsy)
XD2 = ds.FileExists(kls1_2 & "\" & dsy)

If Not XD1 And Not XD2 Then
    MsgBox "İkisinde de yok.": Exit Sub 'İKİ KAYNAK KLASÖR SEÇENEĞİ DE YOKSA İŞLEM SONLANDIRILIR
Else
    If XD1 = True Then Klas1 = kls1_1
    If XD2 = True Then Klas1 = kls1_2
End If

'   BURDAN SONRA ARTIK KLAS1 BULUNDU VE İŞLEME DEVAM EDİLEBİLİR

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
End Sub
Ömer hocam hata vermedi ancak dosyaları belirtilen klasörlerde bulup hedef klasöre kopyalamada yapmadı.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

Ömer BARAN

Kurucu
Yönetici
Kurucu
Versiyon
  1. Excel 2013
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Bilgisayardan kalktım.
O kısma zaten bakmamıştm.

Kodda üst taraftaki dsy =.....kısmına kendi belgenizin tam adını yazdığınızdan emin misiniz?

Bilgisayara geçtiğimde test edip cevap yazarım.

.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

Ömer BARAN

Kurucu
Yönetici
Kurucu
Versiyon
  1. Excel 2013
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Kodda üst taraftaki dsy =.....kısmına kendi belgenizin tam adını yazdığınızdan emin misiniz?
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

mertatakan_3838

Yeni Üye
Kullanıcı
Versiyon
  1. Excel 2016
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Kodda üst taraftaki dsy =.....kısmına kendi belgenizin tam adını yazdığınızdan emin misiniz?
Eminim Ömer hocam 4520.xlsm
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

Ömer BARAN

Kurucu
Yönetici
Kurucu
Versiyon
  1. Excel 2013
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Örnek belgenizi görsek iyi olurdu.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

mertatakan_3838

Yeni Üye
Kullanıcı
Versiyon
  1. Excel 2016
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Örnek belgenizi görsek iyi olurdu.
Örnek dosya
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

Ekli dosyalar (Dosyaları İndirmek İçin Beğenmeniz Gerekir)

  • 4520.xlsm
    21.5 KB · Görüntüleme: 2

Ömer BARAN

Kurucu
Yönetici
Kurucu
Versiyon
  1. Excel 2013
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

4 numaralı cevaptaki kodu güncelledim.

Klas1_1 ve Klas1_2 veri ALINACAK iki dosya yolu.
Klas2 ise veri AKTARILACAK dosya yolu.

-- Belgenin kullanılacağı bilgisayarda, Klas1_1 ve Klas1_2 klasörlerinin ikisi de yoksa buna ilişkin uyarı alırsınız.
-- Belgenin kullanılacağı bilgisayarda, Klas2 klasörü yoksa buna ailişkin uyarı alırsınız.
-- Klas1_1 ve Klas1_2 klasörlerinin (veri alınacak klasör seçenekleri) her ikisi de varsa öncelik,
Set A=..... satırının üstündeki If....Elseif .... End If kısmındaki önceliktir.

Sayfayı yenileyerek 4 numaralı cevabı tekrar kontrol edin.

.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

mertatakan_3838

Yeni Üye
Kullanıcı
Versiyon
  1. Excel 2016
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

4 numaralı cevaptaki kodu güncelledim.

Klas1_1 ve Klas1_2 veri ALINACAK iki dosya yolu.
Klas2 ise veri AKTARILACAK dosya yolu.

-- Belgenin kullanılacağı bilgisayarda, Klas1_1 ve Klas1_2 klasörlerinin ikisi de yoksa buna ilişkin uyarı alırsınız.
-- Belgenin kullanılacağı bilgisayarda, Klas2 klasörü yoksa buna ailişkin uyarı alırsınız.
-- Klas1_1 ve Klas1_2 klasörlerinin (veri alınacak klasör seçenekleri) her ikisi de varsa öncelik,
Set A=..... satırının üstündeki If....Elseif .... End If kısmındaki önceliktir.

Sayfayı yenileyerek 4 numaralı cevabı tekrar kontrol edin.

.
Ömer hocam Kls1_1 klasörüde masaüstünde yazmış olduğunuz makroda Klas1_1 = ThisWorkbook.Path & "\" şeklinde yazıyor bu hali ile makroyu çalıştırdım dosya kopyalamadı
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

Ömer BARAN

Kurucu
Yönetici
Kurucu
Versiyon
  1. Excel 2013
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Klas1_1 ve Klas1_2 kopyalanacak belgeye ilişkin KAYNAK klasörü için yol altarnatifleri.

Klas2 ise kaynaktan alınıp, kopyasının kaydedileceği HEDEF klasör.

Yani ilgili tc no, Klas1_1 veya Klas1_2 klasöründe varsa, Klas2 klasörüne kopyalanır.

Bilgisayarda olmadığım için ancak bu kadar açıklayabildim.
.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

Ömer BARAN

Kurucu
Yönetici
Kurucu
Versiyon
  1. Excel 2013
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Sayın @mertatakan_3838 .
Sanırım bir yanlışyık oldu, kaynak dizinlerden ikincisiyle hedef klasörün dizinini aynı yazmışım.
4 numaralı cevapta tekrar güncelleme yaptım. Sanırım son hali daha anlaşılır oldu.

Sayfayı yenileyip 4 numaralı cevabı tekrar kontrol edin.
Kodun yeni halini belgenize uygulayınca YEŞİL yazı rengi olan açıklama kısımları daha iyi görülür.

.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

mertatakan_3838

Yeni Üye
Kullanıcı
Versiyon
  1. Excel 2016
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Sayın @mertatakan_3838 .
Sanırım bir yanlışyık oldu, kaynak dizinlerden ikincisiyle hedef klasörün dizinini aynı yazmışım.
4 numaralı cevapta tekrar güncelleme yaptım. Sanırım son hali daha anlaşılır oldu.

Sayfayı yenileyip 4 numaralı cevabı tekrar kontrol edin.
Kodun yeni halini belgenize uygulayınca YEŞİL yazı rengi olan açıklama kısımları daha iyi görülür.

.
Ömer hocam öncelikle uğraşınız için çok teşekkür ederim. Revize etmiş olduğunuz 4 nolu mesajdaki makroyu denedim. Sayfanın A sütununa iki farklı biri kaynak 1 klasöründe diğeri kaynak 2 klasöründe olacak şekilde TC kimlik numarası yazıp makroyu çalıştırdım. Kaynak 1 klasöründeki dosyayı hedef klasöre kopyalarken kaynak 2 klasöründeki dosyayı hedef klasöre kopyalamadı.
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

Ömer BARAN

Kurucu
Yönetici
Kurucu
Versiyon
  1. Excel 2013
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Sizin kevcut kodunuz da, benim verdiğim çözüm cevabında da veri alınacak klasör kodun en başında,
A sütunundaki TC kimlik numaralarından bağımsız olarak 1 kez tespit ediliyor idi.

Kaynak tespitini, A sütunundaki herbir hücre için ayrı ayrı yapmak için; aşağıdaki kodu kullanın.
Dikkat: kaynak1, kaynak2 ve hedef kasörlerine ilişkin YOL bilgilerini tekrar kontrol etmeyi unutmayın.

C++:
Sub KLASORDEN_KLASORE_BELGE_KOPYALA()
Dim ds As Object
Dim kaynak1 As String, kaynak2 As String
Dim hedef As String, dsy As String

kaynak1 = "C:\Users\admin\Downloads" & "\"
kaynak2 = "C:\Users\admin\Documents\"
hedef = "C:\Users\admin\Downloads\Pivot_Table\"

Set ds = CreateObject("Scripting.FileSystemObject")
If Not ds.FolderExists(hedef) Then
    MsgBox "Veri TAŞINACAK klasör YOK": Exit Sub
End If

For i = 2 To Cells(Rows.Count, "A").End(3).Row
    If Trim(Cells(i, "A").Value) <> "" Then
        dsy1 = Dir(kaynak1 & Trim(Cells(i, "A").Value) & "*.*", vbDirectory)
        dsy2 = Dir(kaynak2 & Trim(Cells(i, "A").Value) & "*.*", vbDirectory)
        If ds.FileExists(kaynak1 & dsy1) = True Then
            ds.copyFile Source:=kaynak1 & dsy1, Destination:=hedef
            Cells(i, "A").Interior.ColorIndex = 4
        ElseIf ds.FileExists(kaynak2 & dsy2) = True Then
            ds.copyFile Source:=kaynak2 & dsy2, Destination:=hedef
            Cells(i, "A").Interior.ColorIndex = 4
        Else: Cells(i, "A").Interior.ColorIndex = 3
        End If
    End If
Next
MsgBox "işlem tamam"
End Sub
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

mertatakan_3838

Yeni Üye
Kullanıcı
Versiyon
  1. Excel 2016
Sürüm
  1. 32 bit
Dil
  1. Türkçe

Reputation:

Sizin kevcut kodunuz da, benim verdiğim çözüm cevabında da veri alınacak klasör kodun en başında,
A sütunundaki TC kimlik numaralarından bağımsız olarak 1 kez tespit ediliyor idi.

Kaynak tespitini, A sütunundaki herbir hücre için ayrı ayrı yapmak için; aşağıdaki kodu kullanın.
Dikkat: kaynak1, kaynak2 ve hedef kasörlerine ilişkin YOL bilgilerini tekrar kontrol etmeyi unutmayın.

C++:
Sub KLASORDEN_KLASORE_BELGE_KOPYALA()
Dim ds As Object
Dim kaynak1 As String, kaynak2 As String
Dim hedef As String, dsy As String

kaynak1 = "C:\Users\admin\Downloads" & "\"
kaynak2 = "C:\Users\admin\Documents\"
hedef = "C:\Users\admin\Downloads\Pivot_Table\"

Set ds = CreateObject("Scripting.FileSystemObject")
If Not ds.FolderExists(hedef) Then
    MsgBox "Veri TAŞINACAK klasör YOK": Exit Sub
End If

For i = 2 To Cells(Rows.Count, "A").End(3).Row
    If Trim(Cells(i, "A").Value) <> "" Then
        dsy1 = Dir(kaynak1 & Trim(Cells(i, "A").Value) & "*.*", vbDirectory)
        dsy2 = Dir(kaynak2 & Trim(Cells(i, "A").Value) & "*.*", vbDirectory)
        If ds.FileExists(kaynak1 & dsy1) = True Then
            ds.copyFile Source:=kaynak1 & dsy1, Destination:=hedef
            Cells(i, "A").Interior.ColorIndex = 4
        ElseIf ds.FileExists(kaynak2 & dsy2) = True Then
            ds.copyFile Source:=kaynak2 & dsy2, Destination:=hedef
            Cells(i, "A").Interior.ColorIndex = 4
        Else: Cells(i, "A").Interior.ColorIndex = 3
        End If
    End If
Next
MsgBox "işlem tamam"
End Sub
Teşekkür ederim Ömer hocam zihnine sağlık şimdi oldu
 



Forumumuzu reklamsız kullanmak, Hazır Excel Dosyaları indirmek ve web sitemize destek olmak için Hesap Yükseltme yapabilirsiniz. Detayları buradan inceleyebilir, hemen hesabınızı yükseltebilirsiniz.

Çözüm
Üst