Sütundaki sayıları bulma

[abbasonline]

Makroyla sütundaki sayıları bulduramıyorum.

 

[halit3]

bu kodu denermisiniz

Sub makro1()
ad = Worksheets(ActiveSheet.Name).Cells(1, 8).Value
If ad = "" Then
MsgBox "Hücesi boş hiç değer seçmediniz ", vbInformation, c & " Hücresi"
Exit Sub
End If
sat = WorksheetFunction.CountA(Worksheets("RAPOR1").Range("A2:A65000")) + 2
sat1 = sat - 1
For i = 2 To WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("B2:B65000")) + 2
If Worksheets(ActiveSheet.Name).Cells(i, 2).Value = ad Then
For j = 1 To 4
Worksheets("RAPOR1").Cells(sat, j).Value = Worksheets(ActiveSheet.Name).Cells(i, j)
Next j
sat = sat + 1
End If
Next i
MsgBox "toplam " & sat - 1 - sat1 & " kişi aktarıldı aktarıldı"
End Sub

 

[halit3]

yada ba kodu

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column <> 8 Then Exit Sub
If Target.Row <> 1 Then Exit Sub
ad = Worksheets(ActiveSheet.Name).Cells(1, 8).Value
If ad = "" Then
MsgBox "Hücesi boş hiç değer seçmediniz ", vbInformation, c & " Hücresi"
Exit Sub
End If
sat = WorksheetFunction.CountA(Worksheets("RAPOR1").Range("A2:A65000")) + 2
sat1 = sat - 1
For i = 2 To WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("B2:B65000")) + 2
If Worksheets(ActiveSheet.Name).Cells(i, 2).Value = Worksheets(ActiveSheet.Name).Cells(1, 8).Value Then
For j = 1 To 4
Worksheets("RAPOR1").Cells(sat, j).Value = Worksheets(ActiveSheet.Name).Cells(i, j)
Next j
sat = sat + 1
End If
Next i
MsgBox "toplam " & sat - 1 - sat1 & " kişi aktarıldı aktarıldı"
End Sub

 

[abbasonline]

her iki vermiş olduğunuz makroyuda denedim diğer arama hücreleride çalışmıyor, teşekkürler.