ExcelVBA.Net sitesine katkıda bulunabilirsiniz

[OMERULLAH]

Sayın Uzman Arkadaşlar,

Aşağıda açıkladığım çalışmayı sitedeki örnekleri inceleyerek yapamadım ve oldukça fazla zaman harcadım. Dolayısıyla konuya hakim uzman arkadaşların yardımına ihtiyaç duymaktayım.
Bir klasör içerisinde "Personel Bilgileri" isimli çalışma kitabım bulunmaktadır. Bunun yanında "Resimler" ve "Data" isimlerinde iki adet daha klasör bulunmaktadır. "Data" ismli klasörlerin içerisinde ise bir çok çalışma kitabı bulunacak olup, kitapların sayfaları ise personelin adı ve soyadından oluşmaktadır.
Personel Bilgileri katabının yine aynı isme sahip sayfasının "C3" hücresine yazılan personel ismini, "Data" klasöründeki çalışma kitaplarında arayarak, personele ait sayfadaki verilerin görselini çağırmak istiyorum.
Daha detaylı anlatım örnek çalışmada bulunmakta olup, siz uzman arkadaşların çok değerli yardımlarını rica ediyorum.

Saygılarımla,
Ömer Ali ÜZÜMCÜ

https://www.dosyaupload.com/ilzR
http://s3.dosya.tc/server17/tx8qq4/Pers ... i.rar.html

[feraz]

Merhaba.

Dener misiniz?

Not:Personel_Bilgileri sayfasındaki 25.ci satırdaki resimler her isim seçiminden sonra üst üste geliyor.
Bu for each kodu ile silinir.Tabi koşul eklemek gerek diğer resim vs.. silinmemesi için.

Kod: Tümünü seç

Sub resmgtr()

Dim klasor, ws As Worksheet


Application.ScreenUpdating = False

With Workbooks(ThisWorkbook.Name).Sheets("Personel_Bilgileri")



For Each klasor In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path & "\Data").Files

    Workbooks.Open klasor
    Windows(klasor.Name).Visible = False
    Workbooks(ThisWorkbook.Name).Activate
   
    For Each ws In Workbooks(klasor.Name).Sheets
   
            If ws.Name = .Range("C3").Value Then
               Workbooks(klasor.Name).Sheets(.Range("C3").Value).Range("A1:F70").Copy
              .Range("A25:F100").Select
               ActiveSheet.Pictures.Paste
              Workbooks(klasor.Name).Application.CutCopyMode = False

            End If
   
    Next
   
    Workbooks(klasor.Name).Close False
Next

End With

Application.ScreenUpdating = True

Set ws = Nothing

End Sub

Kod: Tümünü seç

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [C3]) Is Nothing Then Exit Sub
On Error Resume Next

With Sheets("Personel_Bilgileri")
    .Image1.Picture = LoadPicture("")
    .Image1.PictureSizeMode = fmPictureSizeModeStretch
    .Image1.Picture = LoadPicture(ThisWorkbook.Path & "\Resimler\" & .[C3] & ".jpg")
    .[C3].Select
   Call resmgtr
End With

End Sub

[OMERULLAH]

Sayın Feraz,

Öncelikle konuya gösterdiğiniz ilgi ve yardımınız için size çok teşekkür ederim.
Personel_Bilgileri sayfasındaki 25.ci satırdaki resimler her isim seçiminden sonra üst üste gelmemesi için "for each" kodu entegre etmeniz daha makbule geçecektir.

Saygılarımla.
Ömer Ali ÜZÜMCÜ

[feraz]

Rica ederim.Dün fazla zamanım yoktu bu yüzden bitirememiştim.
Belkide for eache gerek kalmaz eklenen resimin adını buldurursam.
Akşam yaparım nasipse.

[OMERULLAH]

Rica ederim.Dün fazla zamanım yoktu bu yüzden bitirememiştim.
Belkide for eache gerek kalmaz eklenen resimin adını buldurursam.
Akşam yaparım nasipse.

Sayın Feraz,

Departman müdürleri performans değerlendirmelerini yaparak, bu belgeyi kişinin kendisine imzalatarak bize göndermektedirler. Bu sebep ile imzalı gerçek belgeleri scan yapmak durumunda kaldımız için, mevcut uygulamanın Data klasöründe değşiklik yaptık. Kişilere ait PDF formatındaki gerçek dökümanları excel içerisine taşımamıza gerek kalmamıştır. "Personel Bilgileri" sayfasının C3 hücresine yeni bir isim yazıldığı zaman, veya "Veritabanı" sayfasındaki isimlerin üzerine Double Click yapılınca, o kişiye ait PDF dosyasını açması yeterli olacaktır.
Çalışmayı şekillenen yani hali ile tamamlarsanız çok makbule geçecektir.
Hayırlı akşamlar, kolay gelsin.

Saygılarımla.
Ömer Ali ÜZÜMCÜ

http://dosya.co/8yj9i2pzp3d4/Personel_B ... i.rar.html
http://s3.dosya.tc/server17/zh4i8k/Pers ... i.rar.html

[feraz]

Ben yinede yapmıştım dosyayı ekleyeyim belki lazım olabilir.

[feraz]

Merhaba alttaki kod işinizi görür.
Ayrıyeten resimdekini eklemeniz gerek en üstteki resim için.

http://s3.dosya.tc/server17/it8qpr/Pers ... 3.rar.html

Kod: Tümünü seç

Sub Pdf_resmgtr()

    Dim klasor As Object, pdfler As Object

    For Each klasor In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path & "\Data").SubFolders
   
        For Each pdfler In klasor.Files
   
        If Left(LCase(CreateObject("Scripting.FileSystemObject").GetExtensionName(pdfler)), 3) = "pdf" Then
            If pdfler.Name = ThisWorkbook.Sheets("Personel_Bilgileri").[C3] & ".pdf" Then
              CreateObject("Shell.Application").Open (pdfler & "")
              Exit For
           End If
        End If
   
        Next
    Next
Set klasor = Nothing: Set pdfler = Nothing


End Sub

Kod: Tümünü seç


Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [C3]) Is Nothing Then Exit Sub
    On Error Resume Next
   
    With Sheets("Personel_Bilgileri")
        .Image1.Picture = LoadPicture("")
        .Image1.PictureSizeMode = fmPictureSizeModeStretch
        .Image1.Picture = LoadPicture(ThisWorkbook.Path & "\Resimler\" & .[C3] & ".jpg")
        .[C3].Select
       Call Pdf_resmgtr
    End With

End Sub

[feraz]

Kod yavaş çalışırsa alttaki kodu uygulayınız.Öncekinde gereksizkod eklemişim.

Kod: Tümünü seç

Sub Pdf_resmgtr()

    Dim klasor As Object, pdfler As Object

    For Each klasor In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path & "\Data").SubFolders
        For Each pdfler In klasor.Files
            If pdfler.Name = ThisWorkbook.Sheets("Personel_Bilgileri").[C3] & ".pdf" Then
              CreateObject("Shell.Application").Open (pdfler & "")
              GoTo var
           End If
        Next
    Next
var:
Set klasor = Nothing: Set pdfler = Nothing

End Sub

[OMERULLAH]

Sayın Feraz,

Harika bir çalışma olmuş, konuya gösterdiğiniz ilgi ve benim için çok değerli olan yardımınız için size çok teşekkür ederim.
ALLAH sizden razı olsun ve dilediğiniz herşeyi hayırlısı ile gönlünüze göre versin.

Saygılarımla,
Ömer Ali ÜZÜMCÜ

[feraz]

Rica ederim.
Allah sizdende razı olsun.

Kolay gelsin.