makro ile düşeyara formülü düzenleme

[puslukurt]

Merhabalar...
Aşağıdaki kodu sitemizden buldum. bu kodda ufak bir değişiklik yapmak istiyorum. şöyleki;
bu kodda aranan değer ve bulunan değerler aynı sayfada bulunuyor. benim bu kodun bulunduğu (sayfa2) sayfanın haricinde "liste" diye bir sayfam daha var bu liste sayfasında b2:e80 hücrelerinde veriler var bu sayfadan verileri alıp bu kodun bulunduğu (sayfa2) sayfaya yazması gerekiyor. çok deneme yaptım ama olmadı. yardımlarınızı bekliyorum teşekkürler.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, [a1:a20]) Is Nothing Then Exit Sub
For ara = 1 To 20
Range("b" & ara) = WorksheetFunction.VLookup(Range("a" & ara), Range("f:j"), 2, 0)
Range("c" & ara) = WorksheetFunction.VLookup(Range("a" & ara), Range("f:j"), 3, 0)
Range("d" & ara) = WorksheetFunction.VLookup(Range("a" & ara), Range("f:j"), 4, 0)
Range("e" & ara) = WorksheetFunction.VLookup(Range("a" & ara), Range("f:j"), 5, 0)
If Range("a" & ara) = "" Then
Range("a" & ara).Offset(0, 1) = ""
Range("a" & ara).Offset(0, 2) = ""
End If
Next
End Sub

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki gibi sayfa belirtmelisiniz.

Range("b" & ara) = WorksheetFunction.VLookup(worksheets("liste").Range("a" & ara), worksheets("liste").Range("f:j"), 2, 0)

 

[puslukurt]

Muzaffer Ali Bey merhaba;
ilginiz için öncelikle teşekkür ederim
sizin dediğiniz gibi sayfa belirttim.

Range("b" & ara) = WorksheetFunction.VLookup(worksheets("liste").Range("a" & ara), worksheets("liste").Range("f:j"), 2, 0)

ancak çalışmadı .... sonra yukarı kodda yeşil renkte belirttiğim kodu silince oldu lakin bu seferde 5 saniye gecikmeyle verileri getiriyor. nerede hata yapıyorum bilemiyorum.

 

[Muzaffer Ali]

Veriler fazla olduğu için bekletiyor olabilir.

 

[puslukurt]

peki muzaffer ali bey yeşil ile belirttiğim kodu (worksheets("liste") silmem doğrumudur

 

[Muzaffer Ali]

worksheets("liste").Range("a" & ara) kısmı aranan değer kısmıdır.
Aradığınız değer aktif sayfadaysa sayfa belirmenize gerek yok. Başka sayfadaysa sayfa adı belirtmelisiniz.

Buna göre silmenizin doğru olup olmadığını siz daha iyi bilirsiniz.

 

[puslukurt]

Muzaffer Ali Bey deneye yanıla verilerin gecikmesinin sebebini buldum şimdi anlık geliyor şöyle ki ; verilerin gecikmesine sebeb olan aşağıda ki kod b2 sutunu boş ise c,d,g satırlarını sil kodu geciktirmeye sebeb oluyormuş. Acaba bunu düzeltebilir miyiz. şimdiden teşekkürler


If Range("a" & ara) = "" Then
Range("a" & ara).Offset(0, 1) = ""
Range("a" & ara).Offset(0, 2) = ""
End If

 

[Muzaffer Ali]

Private Sub Worksheet_Change(ByVal Target As Range)

satının altına

application.enableevents=false

ve

End Sub

satırın üstüne

application.enableevents=true

satırlarını ekleyin.

aşağıdaki gibi olmalı.

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
.
.
.
.
Application.EnableEvents = True
End Sub

 

[puslukurt]

Muzaffer Ali Bey aynı sizin dediğinizi yaptım yine gecikme yaptırıyor. yaptığım kod aşağıda bir bakabilirmisiniz bir yerde hata yapıyorum sanırım

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error Resume Next
If Intersect(Target, [b1:b100]) Is Nothing Then Exit Sub
For ara = 1 To 100
Range("c" & ara) = WorksheetFunction.VLookup(Range("b" & ara), Worksheets("liste").Range("b:e"), 2, 0)
Range("d" & ara) = WorksheetFunction.VLookup(Range("b" & ara), Worksheets("liste").Range("b:e"), 3, 0)
Range("g" & ara) = WorksheetFunction.VLookup(Range("b" & ara), Worksheets("liste").Range("b:e"), 4, 0)
If Range("b" & ara) = "" Then
Range("b" & ara).Offset(0, 1) = ""
Range("b" & ara).Offset(0, 2) = ""
Range("b" & ara).Offset(0, 5) = ""
End If
Next
Application.EnableEvents = True
End Sub

 

[Muzaffer Ali]

Aşağıdaki kodu deneyin

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
   
    If Not Intersect(Target, Range("B1:B100")) Is Nothing Then
        For ara = 1 To 100
            If Range("B" & ara) = "" Then
                Range("C" & ara) = ""
                Range("D" & ara) = ""
                Range("G" & ara) = ""
            Else
                Range("C" & ara) = WorksheetFunction.VLookup(Range("B" & ara), Worksheets("liste").Range("B:E"), 2, 0)
                Range("D" & ara) = WorksheetFunction.VLookup(Range("B" & ara), Worksheets("liste").Range("B:E"), 3, 0)
                Range("G" & ara) = WorksheetFunction.VLookup(Range("B" & ara), Worksheets("liste").Range("B:E"), 4, 0)
            End If
        Next
    End If
    Application.EnableEvents = True
End Sub

 

[puslukurt]

bu kod ile verileri getirmedi

 

[Muzaffer Ali]

O zaman dosyanızı paylaşın kontrol edelim. Dosyayı görmeden olmuyor.

 

[puslukurt]

https://ddei5-0-ctp.trendmicro.com:443/wis/clicktime/v1/query?url=https://s6.dosya.tc/server16/70f53p/duseyara.xlsm.html&umid=51DCD590-0901-0706-A8AE-794826CC22B7&auth=2b57225d7664c366d69468155888f41ab3ea5881-f3a58d3d03e220bc1b8cba0c9cf4cc564229b158

 

[Muzaffer Ali]

Şu kodu deneyin.

Private Sub sWorksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Not Intersect(Target, Range("B1:B100")) Is Nothing Then
            If Range("B" & Target.Row) = "" Then
                Range("C" & Target.Row) = ""
                Range("D" & Target.Row) = ""
                Range("G" & Target.Row) = ""
            Else
                Range("C" & Target.Row) = WorksheetFunction.VLookup(Range("B" & Target.Row), Worksheets("liste").Range("B:E"), 2, 0)
                Range("D" & Target.Row) = WorksheetFunction.VLookup(Range("B" & Target.Row), Worksheets("liste").Range("B:E"), 3, 0)
                Range("G" & Target.Row) = WorksheetFunction.VLookup(Range("B" & Target.Row), Worksheets("liste").Range("B:E"), 4, 0)
            End If
    End If
    Application.EnableEvents = True
End Sub

 

[puslukurt]

yok olmadı Muzaffer bey hiç veriler gelmiyor. dosyayı yükledim bakabildinizmi

 

[Muzaffer Ali]

Son kodları denediniz mi?
Eğer olmuyorsa, nasıl olmuyor? Hata mı veriyor, yanlış bilgi mi geliyor, hiç bilgi gelmiyor mu? Tam olarak olmayan nedir?
Ben burada deniyorum, oluyor.

B2 hücresinden aşağıya doğru bir K.No yazınca C, D ve G sütunlarına bilgiler geliyor.
B de bir hücreyi silince C, D ve G sütunlarındaki bilgiler siliniyor.

Son kodlar dosyaya uygulanmış şekilde ekliyorum.

duseyara.xlsm dosyasını indir - download

duseyara.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

 

[Korhan Ayhan]

Alternatif olsun..

Belki çalışma bakımından daha hızlı sonuç verebilir..

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Last_Row As Long
    Application.EnableEvents = False
    If Target.Column = 2 Then
        Range("C2:D" & Rows.Count).ClearContents
        Range("G2:G" & Rows.Count).ClearContents
        Last_Row = Cells(Rows.Count, 2).End(3).Row
        If Last_Row < 2 Then GoTo 10
        With Range("C2:C" & Last_Row)
            .Formula = "=IFERROR(VLOOKUP(B2,'liste'!B:E,2,0),"""")"
            .Value = .Value
        End With
        With Range("D2:D" & Last_Row)
            .Formula = "=IFERROR(VLOOKUP(B2,'liste'!B:E,3,0),"""")"
            .Value = .Value
        End With
        With Range("G2:G" & Last_Row)
            .Formula = "=IFERROR(VLOOKUP(B2,'liste'!B:E,4,0),"""")"
            .Value = .Value
        End With
    End If
10  Application.EnableEvents = True
End Sub

 

[puslukurt]

Muzaffer Ali Bey ve Korhan Ayhan bey ilginizden dolayı ikinize de ayrı ayrı teşekkür ederim. elinize bilginize sağlık istediğim gibi oldu.