yazı içinde ilk harfi uyanlarin bilgilerini getirme

[redje]

Merhaba Arkadaşlar

benim ufak bir makroya ihtiyacım var
makroyu çalıştırdığımda bilgi sayfasındaki x sütununda yazan t ile başlayan tüm bilgileri süzerek karşılığında istediğim bilgilerin yukardaki gibi gelmesini sağlayacak basit bir makroya ihtiyacim var bu konuda yardimlarinizi bekliyorum.

herkese iyi çalışmalar.

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Option Compare Text
 
Sub tOlaniAktar()
    
    Dim i As Long, sat As Long, Sb As Worksheet
    
    Set Sb = Sheets("Bilgi")
    
    Application.ScreenUpdating = False
    
    Sheets("Sayfa1").Select
    Range("D6:K" & Rows.Count).ClearContents
    
    sat = 6
    For i = 2 To Sb.Cells(Rows.Count, "B").End(xlUp).Row
        If Left(Sb.Cells(i, "X"), 1) = "t" Then
            Sb.Range("B" & i & ":G" & i).Copy Range("D" & sat)
            Range("K" & sat) = Sb.Cells(i, "X")
            sat = sat + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
  
End Sub

.

 

[redje]

Merhaba,

Bu şekilde deneyin.

Option Compare Text
 
Sub tOlaniAktar()
    
    Dim i As Long, sat As Long, Sb As Worksheet
    
    Set Sb = Sheets("Bilgi")
    
    Application.ScreenUpdating = False
    
    Sheets("Sayfa1").Select
    Range("D6:K" & Rows.Count).ClearContents
    
    sat = 6
    For i = 2 To Sb.Cells(Rows.Count, "B").End(xlUp).Row
        If Left(Sb.Cells(i, "X"), 1) = "t" Then
            Sb.Range("B" & i & ":G" & i).Copy Range("D" & sat)
            Range("K" & sat) = Sb.Cells(i, "X")
            sat = sat + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
  
End Sub

.

ömer haca merhaba,

çok teşekkür ederim çok güzel ve anlaşılır olmuş aşağıda bu makroda ufak bir değişiklik yaparak
İdari Personel yazanları getirmemesini sağladım yalnız ufak bir sorun oldu boş olan
hiç bişi yazmayanlarıda getiriyor boş olanlarıda getirmemesinide eklerseniz sevinirim

iyi çalışmalar.


Sub tOlaniAktar()

Dim i As Long, sat As Long, Sb As Worksheet

Set Sb = Sheets("Bilgi")

Application.ScreenUpdating = False

Sheets("Sayfa1").Select
Range("D6:K" & Rows.Count).ClearContents

sat = 6
For i = 2 To Sb.Cells(Rows.Count, "B").End(xlUp).Row
If Left(Sb.Cells(i, "X"), 15) <> "İdari Personel" Then
Sb.Range("B" & i & ":G" & i).Copy Range("D" & sat)
Range("K" & sat) = Sb.Cells(i, "X")
sat = sat + 1
End If
Next i

Application.ScreenUpdating = True

End Sub

 

[Ömer]

If Left(Sb.Cells(i, "X"), 15) <> "İdari Personel" Then

satırı yerine aşağıdaki satırı yazın.

If Left(Sb.Cells(i, "X"), 15) <> "İdari Personel" And Sb.Cells(i, "X") <> "" Then

.

 

[redje]

ömer hoca,

Geçmiş zamanlarda ve yine çok büyük yardımlarınız oldu çok teşekkür ederim kolay ve basit bir makro olması başka işlemlerim içinde kullanabilmemi kolaylaştırdı
Tekrar çok teşekkür ederim.
İyi çalışmalar.

 

[redje]

Ömer Hacam Merhaba

bu hazirlamış olduğunuz makro içine ufak bir ekleme isticektim sayfa2 deki c3 sütunundaki formülü veya yaziyi kopyalayıp aşağıdaki makroda süzülen bilgilerin karşısına yani n sütununa yapıştırma eklenenbilirmi yardımlarınız için teşekkürler

iyi çalışmalar



Option Compare Text

Sub tOlaniAktar()

Dim i As Long, sat As Long, Sb As Worksheet

Set Sb = Sheets("Bilgi")

Application.ScreenUpdating = False

Sheets("Sayfa1").Select
Range("D6:K" & Rows.Count).ClearContents

sat = 6
For i = 2 To Sb.Cells(Rows.Count, "B").End(xlUp).Row
If Left(Sb.Cells(i, "X"), 1) = "t" Then
Sb.Range("B" & i & ":G" & i).Copy Range("D" & sat)
Range("K" & sat) = Sb.Cells(i, "X")
sat = sat + 1
End If
Next i

Application.ScreenUpdating = True

End Sub

 

[Ömer]

Sorunuzu anlayamadım, örnek ekleyerek detaylı açıklarmısınız.

 

[redje]

merhaba ömer hoca ;

Dosyanın içerisinde açıkalama yaparak ekledim.

iyi çalışmalar.

 

[Ömer]

merhaba ömer hoca ;
Dosyanın içerisinde açıkalama yaparak ekledim.

Bu şekilde deneyin. Kırmızı renki olan yeni ilavedir.

Option Compare Text
 
Sub tOlaniAktar()
 
    Dim i As Long, sat As Long, Sb As Worksheet
 
    Set Sb = Sheets("Bilgi")
 
    Application.ScreenUpdating = False
 
    Sheets("Sayfa1").Select
    Range("D6:[COLOR=red]L[/COLOR]" & Rows.Count).ClearContents
 
    sat = 6
    For i = 2 To Sb.Cells(Rows.Count, "B").End(xlUp).Row
        If Left(Sb.Cells(i, "X"), 1) = "t" Then
            Sb.Range("B" & i & ":G" & i).Copy Range("D" & sat)
            Range("K" & sat) = Sb.Cells(i, "X")
            [COLOR=red]Range("L" & sat) = "=VLOOKUP(D" & sat & ",Sayfa4!$B$1:$AH$4503,2,0)"[/COLOR]
            sat = sat + 1
        End If
    Next i
 
    Application.ScreenUpdating = True
 
End Sub

.

 

[redje]

Bu şekilde deneyin. Kırmızı renki olan yeni ilavedir.

Option Compare Text
 
Sub tOlaniAktar()
 
    Dim i As Long, sat As Long, Sb As Worksheet
 
    Set Sb = Sheets("Bilgi")
 
    Application.ScreenUpdating = False
 
    Sheets("Sayfa1").Select
    Range("D6:[COLOR=red]L[/COLOR]" & Rows.Count).ClearContents
 
    sat = 6
    For i = 2 To Sb.Cells(Rows.Count, "B").End(xlUp).Row
        If Left(Sb.Cells(i, "X"), 1) = "t" Then
            Sb.Range("B" & i & ":G" & i).Copy Range("D" & sat)
            Range("K" & sat) = Sb.Cells(i, "X")
            [COLOR=red]Range("L" & sat) = "=VLOOKUP(D" & sat & ",Sayfa4!$B$1:$AH$4503,2,0)"[/COLOR]
            sat = sat + 1
        End If
    Next i
 
    Application.ScreenUpdating = True
 
End Sub

.

Ömer hacam merhaba

Bu Şekliyle de işimi görüyor fakat benim istediğim kopy paste şeklindeki bir çözümdü
L3 hücresine farklı formüller yazacam düşey ara formülü sürekli kalmicek
l3 hücresine hangi formülü yazarsam onu getirmesini sağlayacak çözüm daha çok işimi
görür bu şekilde de yeni bir uygulama öğrenmiş oldum

iyi çalışmalar.

 

[Ömer]

Dosyada I3 hücresi dolu. Açıklamalarınız daha dikkatli yapmanızı rica ederim.

Range("L" & sat) = "=VLOOKUP(D" & sat & ",Sayfa4!$B$1:$AH$4503,2,0)"

satırı yerine,

cells(sat,"I").copy Range("L" & sat)

yazabilirsiniz.

 

[redje]

merhaba ömer hocam,


Anlatım bozukluğu için özür dilerim
L3 hücresi sürekli dolu olacak özellikle ben oraya formül yazacam L4 ten sürükle bırak tekniği gibi o formülü kaç kişi bulduysa onun karşısına getirmiş olacak

iyi çalışmalar.

 

[redje]

Range("L3").Copy Range("L" & sat) bu şekilde yapinca işimi gördü çok özür

yardımlarınız için çok teşekkür ederim

iyi çalışmalar.