Sütunda yazılan 1.,2.,3. değerlere göre

[kelkitli]

Selamlar,
B sütununda farklı isimler var. "HAKEDİLEN" yazılı hücreler en son dolu satıra kadar belirlenip, yukarıdan aşağı 1. olan ("HAKEDİLEN") değerin C sütununa denk gelen değerine 20, 2. sine 20, 3. ya 26, 4. ya 30 yazdırmak istiyorum. Makro olarak yapmaya çalışıyorum. Bir örnek yapılabilirse ben 100 sayfaya çoğaltacağım. Tabi sayfadaki veriler de 35 civarında ama kalanını ben uyarlarım.
Saygılar.

 

[usubaykan]

Merhaba;
Aşağıdaki kodu denermisiniz?

Option Explicit
Sub deneme()
Dim Bul As Range, hücre As Range, Adres As String, No
No = 1
For Each hücre In Range("B1:B" & Range("B65536").End(3).Row)
    Set Bul = hücre.Find(what:="HAKEDİLEN", LookAt:=xlWhole)
        If Not Bul Is Nothing Then
        Adres = Bul.Address
            Do
                If No <= 2 Then Cells(Bul.Row, "C") = 20
                If No = 3 Then Cells(Bul.Row, "C") = 26
                If No = 4 Then Cells(Bul.Row, "C") = 30
                Bul = hücre.FindNext(Bul)
                No = No + 1
            Loop While Not Bul Is Nothing And Adres <> Bul.Address
        End If
Next
MsgBox "İşleminiz tamamlanmıştır.", vbInformation, "Sn: " & Application.UserName
End Sub

 

[kelkitli]

Sayın usubaykan, teşekkür ederim.

 

[usubaykan]

Sayın usubaykan, teşekkür ederim.

Rica ederim.

 

[mancubus]

yazdırılacak çok sayıda veri olması durumunda işlemi kısaltmak üzere sn usubaykan'ın aktardığı koda aşağıdaki gibi bir ilave yaptım.

alternatif olarak bulunsun veya bir başkasının işine yarayabilir düşüncesi ile aktarıyorum.

Option Explicit
Option Base 1

Sub bul_yaz()

Dim değer, arama
Dim bul As Range, hücre As Range
Dim Adres As String
Dim No As Long, ss As Long, eleman As Long, bulunan As Long

ss = Worksheets("Sayfa2").Cells(Rows.Count, 1).End(3).Row
değer = Worksheets("Sayfa2").Range("A1:A" & ss).Value
arama = "HAKEDİLEN"

eleman = UBound(değer) - LBound(değer) + 1
bulunan = WorksheetFunction.CountIf(Worksheets("Sayfa1").Columns(2), arama)
If eleman <> bulunan Then
    MsgBox "Bulunan ve yazılacak adetleri eşit değil"
    Exit Sub
End If

No = 1
For Each hücre In Worksheets("Sayfa1").Range("B1:B" & Range("B65536").End(3).Row)
    Set bul = hücre.Find(what:=arama, LookAt:=xlWhole)
        If Not bul Is Nothing Then
        Adres = bul.Address
            Do
                Cells(bul.Row, "C") = değer(No, 1)
                bul = hücre.FindNext(bul)
                No = No + 1
            Loop While Not bul Is Nothing And Adres <> bul.Address
        End If
Next

End Sub

 

[kelkitli]

Teşekkürler mancubus