soldan sağa 5 karakter taşıma

[ercan12]

Dostlar merhaba,
ekte bulunan excel de B sayfasında bulunan karışık verileri, A sayfasındaki KOD kısmına aktaracak.
Yani ben sadece A2 hücresine SAVAS yazdığımda B sayfasında SAVAS kelimesi geçen her şeyi getirecek KOD kısmına alt alta yazacak ve NO'yu da karşılarına getirecek. Veya A2 hücresinde datalar filtreli olsa seçtiğim ismin B deki karşılıkları yanına gelirse de süper olur hangisini yapabilirseniz hocalarım .

şimdiden teşekkürler.

 

[ercan12]

68 kişi bakmış, ilgi istiyorum ) kusura bakmayın acil olmasa 2. mesajı atmazdım.

 

[nsertoglu]

aşağıdaki kod ile deneyin:

Sub Key_Detail()
Application.ScreenUpdating = False
sA = "A"
sB = "B"
kes = 5 ' kalacak karakter adedi

Sheets(sA).Select
Range("A2" & Rows.Count).Select
Range("A2" & Rows.Count).ClearContents
With Selection.Interior
.ColorIndex = 2
.Pattern = xlSolid
End With

Sheets(sB).Select
Range("a1:C1").Select
Selection.AutoFilter
Selection.AutoFilter
sonB = Cells(Rows.Count, "b").End(xlUp).Row
sRng = "B1:B" & sonB

Range(sRng).Copy
Cells(1, "s").Select
ActiveSheet.Paste
Application.CutCopyMode = False
For r = 2 To sonB
Cells(r, "s") = Left(Cells(r, "s"), kes)
Next r
ActiveSheet.Range("S1:S" & sonB).RemoveDuplicates Columns:=Array(1), Header:=xlYes
sonS = Cells(Rows.Count, "S").End(xlUp).Row
Range("S1:S" & sonS).Cut
Sheets(sA).Select
Cells(1, "b").Select
ActiveSheet.Paste
Application.CutCopyMode = False
sonB = Cells(Rows.Count, "B").End(xlUp).Row + 2
sec = " "
For r = 2 To sonB
sec = sec & Cells(r, "b") & "-"
Next r

Cells(sonB, "A") = "Detay Veri"
Range("A" & sonB & ":C" & sonB + 1).Select
With Selection.Interior
.ColorIndex = 24
.Pattern = xlSolid
End With
scim = InputBox("Detaylara ulaşım için Sadece Seçiminiz kalsın:", "*ns* ANAHTAR BELİRLEME *ns*", sec, 5000, 5000)

For r = 2 To sonB
If Cells(r, "B") = scim Then
kyB = Cells(r, "b") & "*"
Cells(r, "C") = " Seçilen"
GoSub detayYaz
Exit For
End If
Next r

End

detayYaz:
Sheets(sB).Select
snBB = Cells(Rows.Count, "b").End(xlUp).Row
Runv = "A1:E" & snBB
Range("a1:C1").Select
Selection.AutoFilter
Selection.AutoFilter
ActiveSheet.Range(Runv).AutoFilter Field:=2, Criteria1:=kyB, Operator:=xlAnd
Range("A:C").SpecialCells(xlCellTypeVisible).Copy Range("S1")
Range("A1:C1").AutoFilter
sonS = Cells(Rows.Count, "T").End(xlUp).Row
Range("S1:U" & sonS).Cut
Sheets(sA).Select
Cells(sonB + 1, "a").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Return

End Sub

 

[nsertoglu]

2 nokta üst üste yerine "mutlu" ifadesi görünmektedir, dikkat ediniz..

 

[ercan12]

Teşekkür ederim @nsertoglu .