Aynı İsimde Olanları Listele

[meslek5]

Merhaba, textbox1'de yazılı ismi B4:B100 arasındaki hücrelerde arayıp bulacak ve G, H, I, J, K, L, M, N, O sütununa B, C, D, N, P, Q,, R, T, U sütununda yazılı değerleri alt alta listeleyecek

Yardımlarınızı bekliyorum. şimdiden teşekkür ederim

 

[md3m1ray]

merhaba b4 b100 arasındaki ismi bulunca o ismin karşısındaki verileri mi G, H, I, J, K, L, M, N, O sütununa getirecek

 

[meslek5]

merhaba b4 b100 arasındaki ismi bulunca o ismin karşısındaki verileri mi G, H, I, J, K, L, M, N, O sütununa getirecek

merhaba hocam kafam karışınca sanırım soruyu yanlış yazdım

ismi B sütununda arayacak (B sütununda aynı isimden 1 tanede olabilir, onlarcada olabilir)

B sütununda ismi bulduğunda ismin karşısındaki C, D, N, P, Q, R, T, U sütunlarda yazan değerleri AA, AB, AC, AD, AE, AF, AG, AH sütunlarına yazacak

 

[md3m1ray]

örnek dosyayı inceler misiniz

İndir meslek5örnek xlsm

Dosyayı indir meslek5örnek xlsm

dosya.co

 

[meslek5]

örnek dosyayı inceler misiniz

İndir meslek5örnek xlsm

Dosyayı indir meslek5örnek xlsm

dosya.co

Hocam çok çok teşekkür ederim. Nasıl yaparım diye düşünürken imdadıma yetiştiniz. herşey gönlünüzce olsun..

 

[md3m1ray]

rica ederim iyi calışmalar hoşcakalın

 

[meslek5]

rica ederim iyi calışmalar hoşcakalın

Hocam aynı dosya üzerinde birşey daha rica edebilir miyim. Aranan ismi bulduğunda karşısındaki sütunlardan değerleri çekip 4. satırdan itibaren yerleştiriyor ya işte o aralığı sabitlememiz mümkün mü? yani aranan isim 6'dan fazla olsa bile ismin karşısındaki bulunan değerleri 4. ve 9. satır aralığına yazsın. Aşağıdaki kodda kırmızıyla işaretli olan yer 4 to 9 gibi ayarlanabilir mi?


Sub CopyAllMatchingValues()
Dim ws As Worksheet
Dim searchName As String
Dim searchRange As Range
Dim foundCell As Range
Dim firstAddress As String
Dim targetRow As Long

Set ws = ThisWorkbook.Sheets(1)
ws.Range("AA:AH").ClearContents
searchName = ws.OLEObjects("Textbox1").Object.Text

Set searchRange = ws.Range("B:B")
Set foundCell = searchRange.Find(What:=searchName, LookIn:=xlValues, LookAt:=xlWhole)

If foundCell Is Nothing Then
MsgBox "Aranan isim bulunamadı!", vbExclamation
Exit Sub
End If

firstAddress = foundCell.Address
targetRow = 4

Do
With ws
.Cells(targetRow, "AA").Value = foundCell.Offset(0, 1).Value
.Cells(targetRow, "AB").Value = foundCell.Offset(0, 2).Value
.Cells(targetRow, "AC").Value = foundCell.Offset(0, 12).Value
.Cells(targetRow, "AD").Value = foundCell.Offset(0, 14).Value
.Cells(targetRow, "AE").Value = foundCell.Offset(0, 15).Value
.Cells(targetRow, "AF").Value = foundCell.Offset(0, 16).Value
.Cells(targetRow, "AG").Value = foundCell.Offset(0, 18).Value
.Cells(targetRow, "AH").Value = foundCell.Offset(0, 19).Value
End With

targetRow = targetRow + 1

Set foundCell = searchRange.FindNext(foundCell)
Loop While Not foundCell Is Nothing And foundCell.Address <> firstAddress
End Sub

İndir meslek5örnek xlsm

Dosyayı indir meslek5örnek xlsm

dosya.co

 

[md3m1ray]

dener misiniz

Sub CopyAllMatchingValues()
Dim ws As Worksheet
Dim searchName As String
Dim searchRange As Range
Dim foundCell As Range
Dim firstAddress As String
Dim targetRow As Long
Dim maxRow As Long

Set ws = ThisWorkbook.Sheets(1)
ws.Range("AA:AH").ClearContents
searchName = ws.OLEObjects("Textbox1").Object.Text

Set searchRange = ws.Range("B:B")
Set foundCell = searchRange.Find(What:=searchName, LookIn:=xlValues, LookAt:=xlWhole)

If foundCell Is Nothing Then
MsgBox "Aranan isim bulunamadı!", vbExclamation
Exit Sub
End If

firstAddress = foundCell.Address
targetRow = 4
 maxRow = 9

Do
If targetRow > maxRow Then Exit Do
With ws
.Cells(targetRow, "AA").Value = foundCell.Offset(0, 1).Value
.Cells(targetRow, "AB").Value = foundCell.Offset(0, 2).Value
.Cells(targetRow, "AC").Value = foundCell.Offset(0, 12).Value
.Cells(targetRow, "AD").Value = foundCell.Offset(0, 14).Value
.Cells(targetRow, "AE").Value = foundCell.Offset(0, 15).Value
.Cells(targetRow, "AF").Value = foundCell.Offset(0, 16).Value
.Cells(targetRow, "AG").Value = foundCell.Offset(0, 18).Value
.Cells(targetRow, "AH").Value = foundCell.Offset(0, 19).Value
End With

targetRow = targetRow + 1

Set foundCell = searchRange.FindNext(foundCell)
Loop While Not foundCell Is Nothing And foundCell.Address <> firstAddress
End Sub

 

[meslek5]

dener misiniz

Sub CopyAllMatchingValues()
Dim ws As Worksheet
Dim searchName As String
Dim searchRange As Range
Dim foundCell As Range
Dim firstAddress As String
Dim targetRow As Long
Dim maxRow As Long

Set ws = ThisWorkbook.Sheets(1)
ws.Range("AA:AH").ClearContents
searchName = ws.OLEObjects("Textbox1").Object.Text

Set searchRange = ws.Range("B:B")
Set foundCell = searchRange.Find(What:=searchName, LookIn:=xlValues, LookAt:=xlWhole)

If foundCell Is Nothing Then
MsgBox "Aranan isim bulunamadı!", vbExclamation
Exit Sub
End If

firstAddress = foundCell.Address
targetRow = 4
maxRow = 9

Do
If targetRow > maxRow Then Exit Do
With ws
.Cells(targetRow, "AA").Value = foundCell.Offset(0, 1).Value
.Cells(targetRow, "AB").Value = foundCell.Offset(0, 2).Value
.Cells(targetRow, "AC").Value = foundCell.Offset(0, 12).Value
.Cells(targetRow, "AD").Value = foundCell.Offset(0, 14).Value
.Cells(targetRow, "AE").Value = foundCell.Offset(0, 15).Value
.Cells(targetRow, "AF").Value = foundCell.Offset(0, 16).Value
.Cells(targetRow, "AG").Value = foundCell.Offset(0, 18).Value
.Cells(targetRow, "AH").Value = foundCell.Offset(0, 19).Value
End With

targetRow = targetRow + 1

Set foundCell = searchRange.FindNext(foundCell)
Loop While Not foundCell Is Nothing And foundCell.Address <> firstAddress
End Sub

Hocam tam istediğim gibi. çok çok teşekkür ederim

 

[md3m1ray]

rica ederim