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
Dosyayı indir meslek5örnek xlsm
dosya.co