Düşeyara

[nadirornek]

Nadir sayfasındaki B sutununa karşılık gelen F , G , H sutunlarındaki verileri Sayfa2'nin K sutununa karşılık gelen verileri P , Q , R sutunlarına yazdırmasını istiyorum.
Kodta bir sınırlandırılma konulmuş hepsini bulmuyor.
Nadir Sayfasının B sutununda veri fazla olursa buluyor örnek B sutununda 200 satır olursa buluyor az olursa bulmuyor.Yardımlarınız için teşekkürler.

Sub Düs()
Dim x As Long
On Error Resume Next
Range("P2:R" & Count.Rows).ClearContents
Application.ScreenUpdating = False
Son1 = Sheets("Nadir").Cells(Rows.Count, "B").End(3).Row
Alan = "B2:H" & Son1
For x = 2 To Son1
Range("P" & x).Value = WorksheetFunction.VLookup(Range("K" & x), Sheets("Nadir").Range(Alan), 5, 0)
Range("Q" & x).Value = WorksheetFunction.VLookup(Range("K" & x), Sheets("Nadir").Range(Alan), 6, 0)
Range("R" & x).Value = WorksheetFunction.VLookup(Range("K" & x), Sheets("Nadir").Range(Alan), 7, 0)
Next x
Application.ScreenUpdating = True
End Sub

Sayfadaki kod bu

 

[Ziynettin]

Bu şekilde deneyin.

Sub Düs()
Dim x As Long
On Error Resume Next
Range("P2:R" & Count.Rows).ClearContents
Application.ScreenUpdating = False
Son1 = Sheets("Nadir").Cells(Rows.Count, "B").End(3).Row
[COLOR="red"]Son2 = Sheets("Sayfa2").Cells(Rows.Count, "K").End(3).Row[/COLOR]

Alan = "B2:H" & Son1
For x = 2 To [COLOR="Red"]Son2[/COLOR]
Range("P" & x).Value = WorksheetFunction.VLookup(Range("K" & x), Sheets("Nadir").Range(Alan), 5, 0)
Range("Q" & x).Value = WorksheetFunction.VLookup(Range("K" & x), Sheets("Nadir").Range(Alan), 6, 0)
Range("R" & x).Value = WorksheetFunction.VLookup(Range("K" & x), Sheets("Nadir").Range(Alan), 7, 0)
Next x
Application.ScreenUpdating = True
End Sub

 

[nadirornek]

Teşekkürler şimdi güzel oldu kaç tane olursa olsun buluyor.

 

[nadirornek]

Yukarıki kodta biraz değişikliğe ihtiyacım var.
Nadir sayfası sabit kalacak fakat sayfa2 değişiyor.
Nadir sayfası sabit açtığım her yeni sayfada bu kod çalışacak.
Şimdi sadece sayfa2'de çalışıyor.
Yeni açtığım sayfadada bu kodun çalışmasını istiyorum.Her açtığım sayfada koda giderek Sayfa2 ismini değiştiriyorum kodda düzenleyebilirmiyiz.

 

[nadirornek]

Arkadaşlar yokmu bu sorunun ilacı

 

[dellerlim]

Bu şekilde mi olacak?

Sub Düs()
Dim x As Long
On Error Resume Next
Range("P2:R" & Count.Rows).ClearContents
Application.ScreenUpdating = False
Son1 = Sheets("Nadir").Cells(Rows.Count, "B").End(3).Row
[COLOR="Red"]Son2 = ThisWorkbook.ActiveSheet.Cells(Rows.Count, "K").End(3).Row[/COLOR]

Alan = "B2:H" & Son1
For x = 2 To Son2
Range("P" & x).Value = WorksheetFunction.VLookup(Range("K" & x), Sheets("Nadir").Range(Alan), 5, 0)
Range("Q" & x).Value = WorksheetFunction.VLookup(Range("K" & x), Sheets("Nadir").Range(Alan), 6, 0)
Range("R" & x).Value = WorksheetFunction.VLookup(Range("K" & x), Sheets("Nadir").Range(Alan), 7, 0)
Next x
Application.ScreenUpdating = True
End Sub

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub AKTAR()
    Dim X As Long, S1 As Worksheet, Sayfa As Worksheet, Alan As String
    Dim WF As WorksheetFunction, Son1 As Long, Son2 As Long
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Nadir")
    Set WF = WorksheetFunction
    
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> S1.Name Then
            Sayfa.Range("P2:R" & Sayfa.Rows.Count).ClearContents
            Son1 = S1.Cells(S1.Rows.Count, "B").End(3).Row
            Son2 = Sayfa.Cells(Sayfa.Rows.Count, "K").End(3).Row
            Alan = "B$2:H$" & Son1
            
            With Sayfa.Range("P2:P" & Son2)
                .Formula = "=IFERROR(VLOOKUP(K2," & S1.Name & "!" & Alan & ",5,0),"""")"
                .Value = .Value
            End With
        
            With Sayfa.Range("Q2:Q" & Son2)
                .Formula = "=IFERROR(VLOOKUP(K2," & S1.Name & "!" & Alan & ",6,0),"""")"
                .Value = .Value
            End With
            
            With Sayfa.Range("R2:R" & Son2)
                .Formula = "=IFERROR(VLOOKUP(K2," & S1.Name & "!" & Alan & ",7,0),"""")"
                .Value = .Value
            End With
            
        End If
    Next
    
    Application.ScreenUpdating = True
End Sub

 

[nadirornek]

Kodlar için teşekkürler emeğinize sağlık güzel çalışıyor.