Seç renklendir kopyala

[ADER_34]

Selam değerli arkadaşlar hayırlı akşamlar,bir konuda yardıma ihtiyacım var
örnek dosyamda ctrl+ f ile arayıp bulduğum değer eğer F sütununda ise önce bulduğum değeri sonrada o değerin 2 yan satırını ve 5 inci yan satırını renklendirsin yani bulduğum değer, satırı "F" sütununda ise sırasıyla
"A" "D" "E" "F" Sütunlarını renlendirsin,sonrada seçtiğim sayfada
"A" satırını "A" ya "E" satırını "C" ye "D" satırını "F" ye "F" satırını "E" ye değerleri renkleriyle birlikte yapıştırsın kolay gelsin teşekkürler
örnek: sayfa adı "TABLET" satırlar = aranıp bulunan F2 satırı yani F sütununda ise sırasıyla "A2""D2"E2"F2" yi renklendir kopyala "seçilen sayfada"
A2 A2 ye D2 F2 ye E2 C2 ye F2 E2 ye kopyala.
http://www.dosya.tc/server5/sjibju/SEC.xlsx.html

 

[ADER_34]

Arkadaşlar Merhaba dosyamı 12 kişi indirmiş ama bir yanıt yok,rica etsem yardımcı olurmusunuz? teşekkürler..

 

[PLİNT]

Merhaba
Ek dosyadaki gibi işinize yarayabilir.

http://s6.dosya.tc/server4/tnwxn0/SEC.zip.html

Private Sub Worksheet_Deactivate()
x = 1
If [h1] = "" Then Exit Sub
tekrar:
Set a = Range("f" & x & ":f" & Cells(Rows.Count, "f").End(3).Row).Find([h1].Value, lookat:=xlWhole)
If Not a Is Nothing Then
m = m + 1
Range("a" & a.Row & "," & "d" & a.Row & ":f" & a.Row).Interior.ColorIndex = 6
v = Array("a", "d", "e", "f")
v2 = Array("a", "f", "c", "e")
sat = ActiveSheet.Cells(Rows.Count, "a").End(3).Row + 1
For s = 0 To UBound(v)
ActiveSheet.Cells(sat, v2(s)).Value = Cells(a.Row, v(s)).Value
Next
i = WorksheetFunction.CountIf(Range("f1:f" & Cells(Rows.Count, "f").End(3).Row), [h1].Value)
If m <> i Then x = a.Row + 1: GoTo tekrar
End If
[h1] = ""
MsgBox "işlem tamam"
Sayfa3.Select
End Sub

 

[ADER_34]

Sayın Plint tek kelime ile harika işlem tamam kodlar sorunsuz çalışıyor Allah razı olsun hayırlı geceler çok çok teşekkür ederim size....

 

[ADER_34]

Sayın Plint tek kelime ile harika işlem tamam kodlar sorunsuz çalışıyor Allah razı olsun hayırlı geceler çok çok teşekkür ederim size....

Merhaba hayırlı akşamlar arkadaşlar,bu kodlarla sorunuma çare buldum ama bulduğum veriyi H1 satırına değilde H sütununda herhangi bir satıra yapıştırdığımda çalışması mümkünmü?
kodlarrivate Sub Worksheet_Deactivate()
x = 1
If [h1] = "" Then Exit Sub
tekrar:
Set a = Range("f" & x & ":f" & Cells(Rows.Count, "f").End(3).Row).Find([h1].Value, lookat:=xlWhole)
If Not a Is Nothing Then
m = m + 1
Range("a" & a.Row & "," & "d" & a.Row & ":f" & a.Row).Interior.ColorIndex = 6
v = Array("a", "d", "e", "f")
v2 = Array("a", "f", "c", "e")
sat = ActiveSheet.Cells(Rows.Count, "a").End(3).Row + 1
For s = 0 To UBound(v)
ActiveSheet.Cells(sat, v2(s)).Value = Cells(a.Row, v(s)).Value
Next
i = WorksheetFunction.CountIf(Range("f1:f" & Cells(Rows.Count, "f").End(3).Row), [h1].Value)
If m <> i Then x = a.Row + 1: GoTo tekrar
End If
[h1] = ""
'MsgBox "işlem tamam"
'Sayfa3.Select
End Sub
çok teşekkür ederim.Kolay gelsin

 

[PLİNT]

Merhaba hayırlı akşamlar arkadaşlar,bu kodlarla sorunuma çare buldum ama bulduğum veriyi H1 satırına değilde H sütununda herhangi bir satıra yapıştırdığımda çalışması mümkünmü?

Merhaba
İlgili kod sayfasındaki tüm kodları
aşağıdakiyle değiştirip deneyiniz.
(Sayfanızda "Private Sub Worksheet_Change(ByVal Target As Range)"
başlığı altında örnek dosyanızda kod bulunmuyordu, asıl dosyanızda varsa
ona göre düzenleme gerekiyor.)

Private ara

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 8 Then ara = Empty: Exit Sub
ara = Target.Address
End Sub

Private Sub Worksheet_Deactivate()
x = 1
If ara = Empty Then Exit Sub
If Me.Range(ara) = "" Then Exit Sub
Application.EnableEvents = False
tekrar:
Set a = Me.Range("f" & x & ":f" & Me.Cells(Rows.Count, "f").End(3).Row).Find(Trim(Me.Range(ara).Value), lookat:=xlWhole)
If Not a Is Nothing Then
m = m + 1
Me.Range("a" & a.Row & "," & "d" & a.Row & ":f" & a.Row).Interior.ColorIndex = 6
v = Array("a", "d", "e", "f")
v2 = Array("a", "f", "c", "e")
sat = ActiveSheet.Cells(Rows.Count, "a").End(3).Row + 1
For s = 0 To UBound(v)
ActiveSheet.Cells(sat, v2(s)).Value = Me.Cells(a.Row, v(s)).Value
Next
i = WorksheetFunction.CountIf(Me.Range("f1:f" & Me.Cells(Rows.Count, "f").End(3).Row), Trim(Me.Range(ara).Value))
If m <> i Then x = a.Row + 1: GoTo tekrar
Else
Application.EnableEvents = True
MsgBox "veri bulunamadı"
Exit Sub
End If
Me.Range(ara) = Empty
Me.Range(ara).Interior.ColorIndex = xlNone
ara = Empty
MsgBox "işlem tamam"
Application.CutCopyMode = False
Sayfa3.Select
Application.EnableEvents = True
End Sub

 

[ADER_34]

Sayın Plint muhteşemsiniz tek kelime ile kodlar sorunsuz,peki bunu crtl f ile arayıp bulduğumda yapmam mümkünmü?