vba Hlookup fonksiyonu

[hüseyintok]

Merhaba ekte paylaştığım C3 hücresindeki değere göre, G3:Z Son dolu satır arasında ki değeri hlookup yada başka bir yöntemle vba olarak c4 den itibaren dolu satır karşılığı getirtmek istiyorum. formülle çok kasıyor yaklaşım 15.000 satırda formül yapmak zorunda kalıyorum. VBA olarak nasıl bir kod yazabilirim?

 

[Tevfik_Kursun]

Günaydın Sayın HüseyinTok,
Deneyiniz arkadaşım.
İyi çalışmalar

 

[hüseyintok]

Teşekkürler Tevfik bey, fakat alınan değerlerde "0" olursa veya boş hücre olursa fonksiyon çalışmıyor. Bu hatayı nasıl giderebiliriz?

 

[YUSUF44]

Cevabı silme nedenim: Sayın @Tevfik_Kursun 'un cevabını görmemiştim. Kusura bakmayın.

 

[Tevfik_Kursun]

Tamam Yusuf Hocam,
Hızlısınız, kabul ettik
Herkese iyi çalışmalar

 

[Tevfik_Kursun]

Sayın Hüseyin Tok,
Deneyiniz arkadaşım.
İyi çalışmalar
Not: Şöyle bir sorun var, 3. satırda tekrarlayan tarih olursa ilk sütunu getirir.

 

[Tevfik_Kursun]

Sayın Hüseyin Tok,
Bu da alternatif çözüm
Deneyiniz arkadaşım.
İyi çalışmalar
Not: Şöyle bir sorun var, 3. satırda tekrarlayan tarih olursa ilk sütunu getirir.

 

[hüseyintok]

Teyfik bey günaydın. ekteki senaryoda yine çalışmadı. mantık hatası var sanırım. ilk aylarda boşluk varsa hesaplama yapmıyor. TK3 de çalıştıramadım

 

[Tevfik_Kursun]

Günaydın Arkadaşım,
Son satır değerini G sütunundan alıyor. Son değerini el ile verin. Bu işlemi yaptığınızda her zaman çalışır.

    On Error Resume Next
'    Son = Cells(Rows.Count, "G").End(3).Row
    Son = 1000

kod içindeki gibi.
İyi çalışmalar

 

[hüseyintok]

Teşekkürler Teyfik bey yaklaşık 15.000 satır var ve manuel verdiğimde çok kasıyor ve kitleniyor. TK3 ü çalıştıramadım orada ki mantık kurtarır mı?

 

[Tevfik_Kursun]

Kesinlikle, her ikisi de çözümler. Sıkıntı olursa bakarım

 

[hüseyintok]

Teşekkürler ilginiz için. TK3 daha uygun oldu ama. veri olmayan aylarda ay bilgisini getiriyor. Ekte paylaşıyorum o sıkıntıyı çözerseniz sorun kalmayacak

 

[Tevfik_Kursun]

Merhaba,
Buyrun
İyi çalışmalar

 

[Korhan Ayhan]

Alternatif;

Önerdiğim kod belirlenen sütundaki aşağıdaki verileri listeler. İsteğe göre düzenlenebilir. Gerçek anlamda BOŞ olan hücreleri pas geçer.

Sabit (Sayı+Metin)
Formül (Sayı+Metin)

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sutun As Integer, Alan As Range
    Dim Alan_1 As Range, Alan_2 As Range
    
    If Intersect(Target, Range("C3")) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Sutun = WorksheetFunction.Match(Target, Range("G3:Z3"), 0)
    Range("C4:C" & Rows.Count).ClearContents
    
    On Error Resume Next
    Set Alan_1 = Nothing
    Set Alan_2 = Nothing
    Set Alan_1 = Cells(4, Sutun + 6).Resize(Rows.Count - 3).SpecialCells(xlCellTypeConstants, 3)
    Set Alan_2 = Cells(4, Sutun + 6).Resize(Rows.Count - 3).SpecialCells(xlCellTypeFormulas, 3)
    If Not Alan_1 Is Nothing And Not Alan_2 Is Nothing Then
        Set Alan = Union(Alan_1, Alan_2)
    ElseIf Not Alan_1 Is Nothing Then
        Set Alan = Alan_1
    ElseIf Not Alan_2 Is Nothing Then
        Set Alan = Alan_2
    Else
        Set Alan = Nothing
    End If
    On Error GoTo 0

    If Not Alan Is Nothing Then
        Alan.Copy
        Range("C4").PasteSpecial xlPasteValues
        Target.Select
        Application.CutCopyMode = False
    End If

    Application.ScreenUpdating = True
End Sub

 

[hüseyintok]

Teşekkürler

 

[Tevfik_Kursun]

Teşekkürler Korhan Hocam,
Farklı bir yöntem görmek te güzel.

 

[hüseyintok]

Alternatif;

Önerdiğim kod belirlenen sütundaki aşağıdaki verileri listeler. İsteğe göre düzenlenebilir. Gerçek anlamda BOŞ olan hücreleri pas geçer.

Sabit (Sayı+Metin)
Formül (Sayı+Metin)

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sutun As Integer, Alan As Range
    Dim Alan_1 As Range, Alan_2 As Range
   
    If Intersect(Target, Range("C3")) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
   
    Application.ScreenUpdating = False
   
    Sutun = WorksheetFunction.Match(Target, Range("G3:Z3"), 0)
    Range("C4:C" & Rows.Count).ClearContents
   
    On Error Resume Next
    Set Alan_1 = Nothing
    Set Alan_2 = Nothing
    Set Alan_1 = Cells(4, Sutun + 6).Resize(Rows.Count - 3).SpecialCells(xlCellTypeConstants, 3)
    Set Alan_2 = Cells(4, Sutun + 6).Resize(Rows.Count - 3).SpecialCells(xlCellTypeFormulas, 3)
    If Not Alan_1 Is Nothing And Not Alan_2 Is Nothing Then
        Set Alan = Union(Alan_1, Alan_2)
    ElseIf Not Alan_1 Is Nothing Then
        Set Alan = Alan_1
    ElseIf Not Alan_2 Is Nothing Then
        Set Alan = Alan_2
    Else
        Set Alan = Nothing
    End If
    On Error GoTo 0

    If Not Alan Is Nothing Then
        Alan.Copy
        Range("C4").PasteSpecial xlPasteValues
        Target.Select
        Application.CutCopyMode = False
    End If

    Application.ScreenUpdating = True
End Sub

Korhan bey sizin çalışmanızda boş satırlar "0" değeri verecek şekilde nasıl düzenleyebiliriz? Sadece dolu olanları getiriyor ve satır kayması yaşıanıyor.