Ay bazında veri çekme

[yanginci34]

Merhaba arkadaşlar; Bir dosyada her personel için ayrı sayfa mevcut birde tüm personellerin bulunduğu icmal sayfası var. İcmal sayfasına a sütununda personel isimleri ve b sutununa gelmesini istediğim bilgi yazacak örneğin a2 hücresinde deneme isminde kişinin verisi b2 hücresine k1 hücresine ay olarak Ocak yazıyorsa deneme sayfasının b34 hücresindeki veri gelsin Şubat yazıyorsa f34 hücresindeki veri, Mart yazıyorsa j34 hücresindeki veri gelsin yani bu Aralık ayına kadar yatay olarak 4 hücre atlayarak veri getirsin. Şimdiden teşekkürler.

 

[yanginci34]

Arkadaşlar formül veya kod ile fark etmez. Yardımcı olursanız sevinirim.

 

[yanginci34]

Aşağıdaki örnekte isteğimi belirttim. Teşekkürler

Ekli dosyayı görüntüle GENEL PUANTAJ.xlsx

 

[çıtır]

Çözümlenmiş dosyanız ektedir.

http://s7.dosya.tc/server3/uztcsd/izin.rar.html

 

[yanginci34]

Üstad çok teşekkür ederim hızır gibi yetiştin yüreğine sağlık kolay gelsin.

 

[çıtır]

Üstad çok teşekkür ederim hızır gibi yetiştin yüreğine sağlık kolay gelsin.

Rica ederim.Dönüş yaptığınız için teşekkür ederim.

 

[yanginci34]

Arkadalar; pekala eğer müsaitseniz ve eğer oluyorsa aşağıdaki formül coda çevirile bilirmi?

=EĞERHATA(İNDİS(DOLAYLI($A3&"!"&"A1:AV42");KAÇINCI(B$2&" :";DOLAYLI($A3&"!"&"A1:A42");0);KAÇINCI($L$1;DOLAYLI($A3&"!"&"A1:AV1");0)+1);"")

 

[yanginci34]

Konu günceldir

 

[yanginci34]

Konu günceldir

 

[Korhan Ayhan]

Sayfanızın kod bölümüne uygulayınız.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, X As Long, Son As Long, Adres As String
    Dim Y As Byte, Ay_Bul As Range, Kriter As Range
    
    If Intersect(Target, Range("K1")) Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    For X = 3 To Son
        Set S1 = Sheets(Cells(X, 1).Text)
        Set Ay_Bul = S1.Range("A1:AZ1").Find(Target, , , xlWhole)
        If Not Ay_Bul Is Nothing Then
            For Y = 2 To 9
                Adres = S1.Cells(1, Ay_Bul.Column).Address & ":" & S1.Cells(Rows.Count, Ay_Bul.Column).Address
                Set Kriter = S1.Range(Adres).Find(Cells(2, Y) & " :", , , xlWhole)
                If Not Kriter Is Nothing Then
                    Cells(X, Y).Value = S1.Cells(Kriter.Row, Ay_Bul.Column + 1).Value
                End If
            Next
        End If
    Next

    Set Ay_Bul = Nothing
    Set Kriter = Nothing

    Application.ScreenUpdating = True
End Sub

 

[yanginci34]

Korhan Hocam dönüş yaptığınız için teşekkürler. Şu an telefon dan cevap veriyorum PC başına geçtiğimde deneyeceğim.

 

[yanginci34]

Korhan Hocam change olayında başka bir kod vardı sizin kodunuzu o kod ile birleştirmeye çalıştım ama beceremedim her halde bir konturol edermisiniz.
Ekli dosyayı görüntüle GENEL PUANTAJxx.xlsm

 

[yanginci34]

Korhan Hocam konu günceldir

 

[yanginci34]

Konu günceldir

 

[yanginci34]

Konu günceldir.

 

[Korhan Ayhan]

Eski kodları silip aşağıdaki kodları deneyiniz.

Dim Sayfa As String
Dim S1 As Worksheet, X As Long, Son As Long, Adres As String
Dim Y As Byte, Ay_Bul As Range, Kriter As Range

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo bitti
    
    If ActiveSheet.Name <> "İCMAL" Then
        Sheets("İCMAL").Select
    Else
        Sayfa = Target.Value
        If Not SayfaVarMi(Sayfa) Then
        If Sayfa <> "" Then Sheets(Sayfa).Select
        End If
    End If
    Exit Sub

bitti:
    
    If Not Intersect(Target, Range("A3:A500")) Is Nothing Then
        If Not SayfaVarMi(Sayfa) Then
            Sheets("Şablon").Copy After:=Sheets(Sheets.Count)
            ActiveSheet.Name = Target.Value
        End If
        Sheets("İCMAL").Select
        
    ElseIf Not Intersect(Target, Range("L1")) Is Nothing Then
        Application.ScreenUpdating = False
        
        Son = Cells(Rows.Count, 1).End(3).Row
        
        For X = 3 To Son
            Set S1 = Sheets(Cells(X, 1).Text)
            Set Ay_Bul = S1.Range("A1:AZ1").Find(Target, , , xlWhole)
            If Not Ay_Bul Is Nothing Then
                For Y = 2 To 10
                    Adres = S1.Cells(1, Ay_Bul.Column).Address & ":" & S1.Cells(Rows.Count, Ay_Bul.Column).Address
                    Set Kriter = S1.Range(Adres).Find(Cells(2, Y) & " :", , , xlWhole)
                    If Not Kriter Is Nothing Then
                        Cells(X, Y).Value = S1.Cells(Kriter.Row, Ay_Bul.Column + 1).Value
                    End If
                Next
            End If
        Next
    
        Set Ay_Bul = Nothing
        Set Kriter = Nothing
    
        Application.ScreenUpdating = True
    End If
End Sub

Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function

 

[yanginci34]

Hocam yüreğine sağlık tam istediğim gibi olmuş. Kolay gelsin.

 

[rekormuhendislik]

İyi Günler

Gelir sayfam da
Gelir panelim de Ocak ayını seçtiğimde ocak ayı gelirleri ekranıma yansısın istiyorum nasıl yapabilirim. işin içinden çıkamadım. Exel de tablomu hazırladım. Userform' a nasıl aktarmalıyım ?

http://s3.dosya.tc/server14/w24lw1/REKOR_SON_V3_degistir.rar.html

 

[yanginci34]

Aşağıdaki dosyayı denermisiniz.
Ekli dosyayı görüntüle REKOR SON.xlsm

 

[rekormuhendislik]

bunu yapmak istiyorum ama gelir panelinin olduğu kısımda ki texboxlara yazsın istiyorum.
texbox54
texbox55
texbox56 ya yazsın istiyorum. bende deneyeceğim şu an inceliyorum.