makroyu diğer sütunlara uygulamak

[adventurous26]

merhaba arkadaşlar ekteki dosyadaki hazırlamış olduğum makroyu diğer sütunlarada uygulamak istiyorum hangi satırdan itibaren kopyalamam gerekiyor yardımcı olursanız çok memnun olurum.

 

[Huseyinkis]

Kodları ekteki gibi denermisiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim adr As Variant
If Intersect(Target, Range("b2:J1000")) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
sutn = Target.Column
If WorksheetFunction.CountIf(Range(Cells(2, sutn), Cells(Cells(Rows.Count, sutn).End(3).Row, sutn)), Target) > 1 Then
 adr3 = Range(Cells(2, sutn), Cells(Cells(Rows.Count, sutn).End(3).Row, sutn)).Find(Target, , , 1).Address
 If Mid(adr3, 4, 3) < Target.Row Then
adr = Range(Cells(2, sutn), Cells(Cells(Rows.Count, sutn).End(3).Row, sutn)).Find(Target, , , 1).Address
MsgBox "Girdiğiniz seri no " & Mid(adr, 2, 1) & Mid(adr, 4, 3) & " nolu hücrede girilmiştir.", vbInformation
Target = ""
Else
Set adr = Range(Cells(2, sutn), Cells(Cells(Rows.Count, sutn).End(3).Row, sutn)).Find(Target, , , 1)
Set adr1 = Range(Cells(2, sutn), Cells(Cells(Rows.Count, sutn).End(3).Row, sutn)).FindNext(adr)
adr2 = adr1.Address
MsgBox "Girdiğiniz seri no " & Mid(adr2, 2, 1) & Mid(adr2, 4, 3) & " nolu hücrede girilmiştir.", vbInformation
Target = ""
End If
Else
Exit Sub
End If
End Sub

 

[adventurous26]

slm

cok teşekkürler arkadaşım eline sağlık güzel çalışıyor.