Soru Sayfadan diğer sayfaya birkaç hücrenin verisi aktarmak ve diğer sayfadan istenilen bilgiyi varolan sayfada popup veya mesaj olarak getirmek.

[Filose]

Herkese merhaba,
Ekte bulunan çalışma sayfasına küçük bir şey ilave etmek istiyorum.

1. Dönem butonuna basıldığında o satırdaki veriler TÜM-GV sayfasında hangi firma ise onun altına aynı yere yazsın. Birde buradaki BQ7 deki hücre verisini ikinci sayfadaki ORT hücresine yazsın

Aynı şekilde 2,3 ve 4.dönem aynı
Burada aynı sayfadan aynı sayfaya aktarabiliyorum 1,2,3,4. dönem tuşların makroları var ama bu pek kullanışlı olmadı.

Ayrı sayfada daha verimli olacak.

Herkese saygı ve sağlık diliyorum.

 

[Muzaffer Ali]

Merhaba.

Butonların kodlarını silin onların yerine aşağıdakileri kopyalayın.

Sub Aktar01()
    Aktar "1. DÖNEM"
End Sub
Sub Aktar02()
    Aktar "2. DÖNEM"
End Sub
Sub Aktar03()
    Aktar "3. DÖNEM"
End Sub
Sub Aktar04()
    Aktar "4. DÖNEM"
End Sub

Sub Aktar(Donem As String)
    Dim FirmaAdi As String
    Dim syfTumGv As Worksheet
    Dim syfGv As Worksheet
    Dim FirmaBul As Range
    Dim FirmaSatir As Long
    Dim Satir As Long
    Set syfTumGv = ThisWorkbook.Worksheets("TÜM-GV")
    Set syfGv = ThisWorkbook.Worksheets("GV")
    FirmaAdi = syfGv.Range("BK44")
    Set FirmaBul = syfTumGv.Range("C:I").Find(FirmaAdi)
    If FirmaBul Is Nothing Then
        MsgBox "Firma bulunamadı.", vbExclamation
        Exit Sub
    End If
    Select Case Donem
        Case "1. DÖNEM"
            FirmaSatir = 2 + FirmaBul.Row
            Satir = 40
           
        Case "2. DÖNEM"
            FirmaSatir = 3 + FirmaBul.Row
            Satir = 41
        Case "3. DÖNEM"
            FirmaSatir = 4 + FirmaBul.Row
            Satir = 42
        Case "4. DÖNEM"
            FirmaSatir = 5 + FirmaBul.Row
            Satir = 43
    End Select
    syfTumGv.Range("D" & FirmaSatir) = syfGv.Range("BP" & Satir)
    syfTumGv.Range("E" & FirmaSatir) = syfGv.Range("BW" & Satir)
    syfTumGv.Range("F" & FirmaSatir) = syfGv.Range("CD" & Satir)
    syfTumGv.Range("G" & FirmaSatir) = syfGv.Range("CI" & Satir)
    syfTumGv.Range("H" & FirmaSatir) = syfGv.Range("CP" & Satir)
    syfTumGv.Range("I" & FirmaSatir) = syfGv.Range("BQ7")
End Sub

GV adlı sayfanın kod kısmına aşağıdaki kodları kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim FirmaAdi As String
    Dim syfTumGv As Worksheet
    Dim FirmaBul As Range
    Dim FotoAlan As Range
    Set syfTumGv = ThisWorkbook.Worksheets("TÜM-GV")
    FirmaAdi = Range("BK44")
    Set FirmaBul = syfTumGv.Range("C:I").Find(FirmaAdi)
    If FirmaBul Is Nothing Then
        MsgBox "Firma bulunamadı.", vbExclamation
        Exit Sub
    End If
    Set FotoAlan = syfTumGv.Range("C" & FirmaBul.Row & ":I" & FirmaBul.Row + 5)
    FotoAlan.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    On Error Resume Next
    Shapes("TumGVFirma").Delete
    Range("BK45").Select
    Paste
    Selection.Name = "TumGVFirma"
End Sub

 

[Filose]

Merhaba Dalgalıkur,
Deniyorum bilgilendiririm. Ellerinize sağlık çok teşekkür ediyorum.
Sağlıkla kalın

 

[Filose]

Tekrar merhaba Dalgalıkur,

Her şey çok güzel olmuş. Tam istediğim gibi.
Popup da çok iyi oldu. Sadece firmanın sadece ilk 6 karakterine baksa yeterli olur. Tamamına bakmasına gerek yok.

Tekrar ellerinize sağlık çok teşekkür ediyorum.

Sağlık ve huzurla kalın...

 

[Muzaffer Ali]

Rica ederim. Kolay gelsin.

 

[Filose]

Merhaba Dalgalıkur,

Sadece BK44 Hücresine firma ismi yazdığım zaman Popup gelmesini sağlayabilirmiyiz.
Çünkü, GV sayfasına girdiğim herhangi bir hücreye değer girdiğimde veya değiştirdiğim de popup her zaman geliyor.
Sadece BK44 hücresine firma ismi yazdığımda olsa çok daha iyi olacak.

Saygı ve hürmetle,

 

[Muzaffer Ali]

Merhaba.
Gözden kaçırmışım.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim FirmaAdi As String
    Dim syfTumGv As Worksheet
    Dim FirmaBul As Range
    Dim FotoAlan As Range
    If Not Intersect(Target, Range("BK44")) Is Nothing Then
        Set syfTumGv = ThisWorkbook.Worksheets("TÜM-GV")
        FirmaAdi = Range("BK44")
        Set FirmaBul = syfTumGv.Range("C:I").Find(FirmaAdi)
        If FirmaBul Is Nothing Then
            MsgBox "Firma bulunamadı.", vbExclamation
            Exit Sub
        End If
        Set FotoAlan = syfTumGv.Range("C" & FirmaBul.Row & ":I" & FirmaBul.Row + 5)
        FotoAlan.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        On Error Resume Next
        Shapes("TumGVFirma").Delete
        Range("BK45").Select
        Paste
        Selection.Name = "TumGVFirma"
    End If
End Sub

 

[Filose]

Çok teşekkür ediyorum. Elinize yüreğinize sağlık.
Sağlıkla kalın.

 

[Filose]

Tekrar merhaba Dalgalıkur,

GV sayfası için yazdığınız bu son kodu aynı excel dosyasının başka bir sayfasında kullanabilirmiyim.
Bu kod çok işime yaradı ellerinize sağlık.

İyi bayramlar diliyorum.

 

[Muzaffer Ali]

Merhaba.
Evet kullanabilirsiniz.
Dosyanızın yedeğini alıp yedek üzerinde denemeler yapın. Hem bu vesile ile belki başka şeyler de öğrenmiş olursunuz.
Yapamadığınız şey olursa yardımcı olmaya çalışırız.
Kolay gelsin.

 

[Filose]

Çok teşekkür ediyorum.
Sağlık ve huzur diliyorum.