Eğer koşulu oluşturma

[sinan05]

Herkese merhabalar, iyi günler. İstediğim makroya cevap alamadığım için bana gerekli kodu öğrenmeye çalışıyorum. İsteğim şu: dosyamda eğer KAYITLAR sayfasının A4:U5000 aralığında ANA SAYFA sayfasının A1 hücresini içeriyorsa koşulunu nasıl kodla yazabilirim. Yani satırların içindeki cümlelerde bir yerinde A1 hücresinde yazan kalem geçiyorsa şeklinde koşul olmalı. Bunu yazdıktan sonra o ifadeyi içeren satırlar kopyalayacağım. Makro var ama o koşulu yazamıyorum. İlgilenirseniz sevinirim.

 

[Orion1]

Buyurun.

Sub bul59()
Dim k As Range
Sheets("KAYITLAR").Range("A2").Value = ""
Set k = Sheets("KAYITLAR").Range("A4:U5000"). _
    Find(Sheets("KAYITLAR").Range("A1").Value, , xlValues, xlPart)
If Not k Is Nothing Then
    Sheets("KAYITLAR").Range("A2").Value = k.Value
End If
End Sub

 

[sinan05]

Buyurun.

Sub bul59()
Dim k As Range
Sheets("KAYITLAR").Range("A2").Value = ""
Set k = Sheets("KAYITLAR").Range("A4:U5000"). _
    Find(Sheets("KAYITLAR").Range("A1").Value, , xlValues, xlPart)
If Not k Is Nothing Then
    Sheets("KAYITLAR").Range("A2").Value = k.Value
End If
End Sub

ARİON1 Hocam süpersiniz çok teşekkür ederim ALLAH RAZI OLSUN eksik olmayın. Fakat çözümleyemedim. acaba benim dosyama göre uyarlayabilirmiyiz rica etsem. Dosyamda KAYITLAR sayfasının A4 ve U5000 aralığında ki hücrelerde(Aslında B ve L sütunlarında veriler var diğer sütunlar sadece rakam var) ANA SAYFA A1 hücresinde yazılan verinin(isim) geçtiği A ve U arası satırlar ANA SAYFA daki A ve U arasındaki hücrelere kopyalansın. Yani ANA SAYFA A1 hücresinde "kalem" yazıyorsa KAYITLAR sayfasının B7 hücresinde cümlenin içerisinde "kalem" geçiyorsa o satırdaki A ve U arasındaki hücreleri ANA SAYFA daki boş olan A VE U arasındaki satırlara kopyalasın. her iki sayfanında taslağı aynı. iki sayfada da 4. satırda veriler başlıyor A VE U hücreleri arasında veriler var. Bu şekilde uyarlayabilirseniz çok sevinirim çok işime yarayacak inanın.

 

[Orion1]

Örnek dosya ekleyiniz ve üzerinde anlatınız.

 

[sinan05]

Örnek dosya ekleyiniz ve üzerinde anlatınız.

Buyrun Hocam http://s4.dosya.tc/server6/wy3sqd/kayit.rar.html

 

[sinan05]

Buyrun Hocam http://s4.dosya.tc/server6/wy3sqd/kayit.rar.html

Hocam dosyayı açınca ilk sayfada açıklama var. orada kayıtlar sayfasında a4 ve u5000 arasında veri aratılsın demek istedim. yani sadece a ve u sütunu değil. Yanlış ifade etmişim.

 

[Orion1]

Hocam dosyayı açınca ilk sayfada açıklama var. orada kayıtlar sayfasında a4 ve u5000 arasında veri aratılsın demek istedim. yani sadece a ve u sütunu değil. Yanlış ifade etmişim.

Bişey anladıysam arap olayım.

 

[Orion1]

Buyurun.

Sub Tarihe_Gore_Veri_Getir()
Application.ScreenUpdating = False
Dim tarih1 As Date, tarih2 As Date, xtarih As Date, k As Range
Dim S1 As Worksheet, S2 As Worksheet, Son As Long, Satır As Long
Worksheets("ANA SAYFA").Range("a4:U2000").ClearContents
tarih1 = Worksheets("ANA SAYFA").Range("a2").Value
tarih2 = Worksheets("ANA SAYFA").Range("b2").Value
Satır = 4
Set S1 = Sheets("ANA SAYFA")
Set S2 = Sheets("KAYITLAR")
S1.Select
    Satır = 4
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        For x = 4 To Son
        
            xtarih = S2.Cells(x, "A").Value
            If xtarih >= tarih1 And xtarih <= tarih2 Then
                If InStr(1, S2.Cells(x, "B").Value, Range("A1").Value) > 0 Then
                    S2.Range("A" & x & ":K" & x).Copy
                    S1.Cells(Satır, 1).PasteSpecial xlPasteAll
                    Satır = Satır + 1
                End If
          End If
        Next x
    Satır = 4
        For x = 4 To Son
        
            xtarih = S2.Cells(x, "A").Value
            If xtarih >= tarih1 And xtarih <= tarih2 Then
                If InStr(1, S2.Cells(x, "L").Value, Range("A1").Value) > 0 Then
                    S2.Range("L" & x & ":U" & x).Copy
                    S1.Cells(Satır, "L").PasteSpecial xlPasteAll
                    Satır = Satır + 1
                End If
          End If
        Next x
Range("A4").Select
Application.ScreenUpdating = True
MsgBox "bitti"
End Sub

 

[sinan05]

Bişey anladıysam arap olayım.

Hocam af buyrun pek anlamadığım için kendimi doğru ifade edemiyorum. O dosyada Tarihe_Gore_Veri_Getir makrosu var. çalıştırınca ANA SAYFA da A2 ve B2 hücrelerindeki tarih aralığını KAYITLAR sayfasında A sütunundaki hücreler de sorguluyor ve uygun olan tarih varsa o satırdaki A dan U ya kadar olan hücreleri ANA SAYFA ya kopyalıyor. Bende buna benzer şekilde kayıtlar sayfasında her satırda A ve U arası hücrelerde ANA SAYFADA A1 hücresinde hangi kelime yazıyorsa o kelimenin KAYITLAR sayfasında olan satırları kopyalayıp ANA sayfaya yapıştırsın. örnek a1 de kalem yazıyorsa kayıtlar sayfasının 4. satırının B hücresinde bir cümlede kalem geçiyorsa A4,B4,K4,L4,U4 hücrelerini içeren o satırı komple ANASAYFA ya aynı şekilde boş olan A VE U arası satıra kopyalasın. çok rica edicem çok güzel olacak benim için.

 

[Orion1]

Tarihi dikkate almayalımmı?
Sadece A1 hücresine göremi arayıp bulalım?

 

[sinan05]

Buyurun.

Sub Tarihe_Gore_Veri_Getir()
Application.ScreenUpdating = False
Dim tarih1 As Date, tarih2 As Date, xtarih As Date, k As Range
Dim S1 As Worksheet, S2 As Worksheet, Son As Long, Satır As Long
Worksheets("ANA SAYFA").Range("a4:U2000").ClearContents
tarih1 = Worksheets("ANA SAYFA").Range("a2").Value
tarih2 = Worksheets("ANA SAYFA").Range("b2").Value
Satır = 4
Set S1 = Sheets("ANA SAYFA")
Set S2 = Sheets("KAYITLAR")
S1.Select
    Satır = 4
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        For x = 4 To Son
       
            xtarih = S2.Cells(x, "A").Value
            If xtarih >= tarih1 And xtarih <= tarih2 Then
                If InStr(1, S2.Cells(x, "B").Value, Range("A1").Value) > 0 Then
                    S2.Range("A" & x & ":K" & x).Copy
                    S1.Cells(Satır, 1).PasteSpecial xlPasteAll
                    Satır = Satır + 1
                End If
          End If
        Next x
    Satır = 4
        For x = 4 To Son
       
            xtarih = S2.Cells(x, "A").Value
            If xtarih >= tarih1 And xtarih <= tarih2 Then
                If InStr(1, S2.Cells(x, "L").Value, Range("A1").Value) > 0 Then
                    S2.Range("L" & x & ":U" & x).Copy
                    S1.Cells(Satır, "L").PasteSpecial xlPasteAll
                    Satır = Satır + 1
                End If
          End If
        Next x
Range("A4").Select
Application.ScreenUpdating = True
MsgBox "bitti"
End Sub

Hocam çok süper oldu tam istediğim buydu işte ALLAH RAZI OLSUN çok hızlı ve güzel çalışıyor hem isme hemde tarihe göre sorguluyor. Fakat hocam ufak bir prüz var. mesela b4 de kalem gördü 4. satırını getircek diyelim fakat L4 de veri yok veya orda kalem geçmiyor. orası boş olduğu için L5 DE KALEM geçiyorsa onu 4. satıra L4 de kopyalıyor. halbuki L4 boş kalmalı yani;

01.05.2019 ahmet kalem aldı 5000 mehmet silgi verdi 100
01.05.2019 mehmet kalem aldı 1000 boş boş (ali kalem getirdi 3000 bu verileri sol tarafa boş olması gereken
01.05.2019 mehmet silgi aldı 250 ali kalem getirdi 3000 yere ekliyor)

böyle olunca tarihe göre yanlış bilgi vermiş oluyor.

 

[sinan05]

Tarihi dikkate almayalımmı?
Sadece A1 hücresine göremi arayıp bulalım?

öylede yapabilirseniz sevinirim hocam iki türlü kullanırım.

 

[Orion1]

Buyurun.

Sub Tarihe_Gore_Ve_A1hucresine_gore_Veri_Getir()
Application.ScreenUpdating = False
Dim tarih1 As Date, tarih2 As Date, xtarih As Date, k As Range, var As Boolean
Dim S1 As Worksheet, S2 As Worksheet, Son As Long, Satır As Long
Worksheets("ANA SAYFA").Range("a4:U2000").ClearContents
tarih1 = Worksheets("ANA SAYFA").Range("a2").Value
tarih2 = Worksheets("ANA SAYFA").Range("b2").Value
Satır = 4
Set S1 = Sheets("ANA SAYFA")
Set S2 = Sheets("KAYITLAR")
S1.Select
    Satır = 4
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        For x = 4 To Son
        
            xtarih = S2.Cells(x, "A").Value
            If xtarih >= tarih1 And xtarih <= tarih2 Then
                If InStr(1, S2.Cells(x, "B").Value, Range("A1").Value) > 0 Then
                    S2.Range("A" & x & ":K" & x).Copy
                    S1.Cells(Satır, 1).PasteSpecial xlPasteAll
                    var = True
                End If
                If InStr(1, S2.Cells(x, "L").Value, Range("A1").Value) > 0 Then
                    S2.Range("L" & x & ":U" & x).Copy
                    S1.Cells(Satır, "L").PasteSpecial xlPasteAll
                    var = True
                End If
            End If
          If var = True Then
            Cells(Satır, "A").Value = S2.Cells(x, "A").Value
            Satır = Satır + 1
          End If
          var = False
        Next x
Range("A4").Select
Application.ScreenUpdating = True
MsgBox "bitti"
End Sub

 

[sinan05]

Buyurun.

Sub Tarihe_Gore_Ve_A1hucresine_gore_Veri_Getir()
Application.ScreenUpdating = False
Dim tarih1 As Date, tarih2 As Date, xtarih As Date, k As Range, var As Boolean
Dim S1 As Worksheet, S2 As Worksheet, Son As Long, Satır As Long
Worksheets("ANA SAYFA").Range("a4:U2000").ClearContents
tarih1 = Worksheets("ANA SAYFA").Range("a2").Value
tarih2 = Worksheets("ANA SAYFA").Range("b2").Value
Satır = 4
Set S1 = Sheets("ANA SAYFA")
Set S2 = Sheets("KAYITLAR")
S1.Select
    Satır = 4
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        For x = 4 To Son
       
            xtarih = S2.Cells(x, "A").Value
            If xtarih >= tarih1 And xtarih <= tarih2 Then
                If InStr(1, S2.Cells(x, "B").Value, Range("A1").Value) > 0 Then
                    S2.Range("A" & x & ":K" & x).Copy
                    S1.Cells(Satır, 1).PasteSpecial xlPasteAll
                    var = True
                End If
                If InStr(1, S2.Cells(x, "L").Value, Range("A1").Value) > 0 Then
                    S2.Range("L" & x & ":U" & x).Copy
                    S1.Cells(Satır, "L").PasteSpecial xlPasteAll
                    var = True
                End If
            End If
          If var = True Then
            Cells(Satır, "A").Value = S2.Cells(x, "A").Value
            Satır = Satır + 1
          End If
          var = False
        Next x
Range("A4").Select
Application.ScreenUpdating = True
MsgBox "bitti"
End Sub

Hocam yoldayım eve varınca deniyeceğim inşallah sağolun

 

[sinan05]

Buyurun.

Sub Tarihe_Gore_Ve_A1hucresine_gore_Veri_Getir()
Application.ScreenUpdating = False
Dim tarih1 As Date, tarih2 As Date, xtarih As Date, k As Range, var As Boolean
Dim S1 As Worksheet, S2 As Worksheet, Son As Long, Satır As Long
Worksheets("ANA SAYFA").Range("a4:U2000").ClearContents
tarih1 = Worksheets("ANA SAYFA").Range("a2").Value
tarih2 = Worksheets("ANA SAYFA").Range("b2").Value
Satır = 4
Set S1 = Sheets("ANA SAYFA")
Set S2 = Sheets("KAYITLAR")
S1.Select
    Satır = 4
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        For x = 4 To Son
       
            xtarih = S2.Cells(x, "A").Value
            If xtarih >= tarih1 And xtarih <= tarih2 Then
                If InStr(1, S2.Cells(x, "B").Value, Range("A1").Value) > 0 Then
                    S2.Range("A" & x & ":K" & x).Copy
                    S1.Cells(Satır, 1).PasteSpecial xlPasteAll
                    var = True
                End If
                If InStr(1, S2.Cells(x, "L").Value, Range("A1").Value) > 0 Then
                    S2.Range("L" & x & ":U" & x).Copy
                    S1.Cells(Satır, "L").PasteSpecial xlPasteAll
                    var = True
                End If
            End If
          If var = True Then
            Cells(Satır, "A").Value = S2.Cells(x, "A").Value
            Satır = Satır + 1
          End If
          var = False
        Next x
Range("A4").Select
Application.ScreenUpdating = True
MsgBox "bitti"
End Sub

HOCAM herşey çok güzel oldu fakat kızmassanız ufak pürüz var. Acaba mümkünse onu da halledseniz acaba ayıp olmazsa sona geldik bitti sayılır. Aslında tam istediğim gibi kalem yazan B4 hücresini getirdi fakat L4 de defter yazdığı için orayı boş bıraktı halbu ki defteri de getirmeliydi. Benim istediğim örneğin satırın bir hücresinde kalem yazıyorsa o satırı özgün haliyle getirsin. sütunlardan biri boşsa boş olarak, kalem yerine başka veri yazıyorsa onuda geirsin. Bunuda yapsanız lütfen çok mutlu olucam.

 

[Orion1]

ama siz A1 hücresine KALEM yazmışsınız.Onun için KALEM getirdi.
A1 hücresine KALEM yerine DEFTER yazarsanız DEFTER i getirir.

 

[Orion1]

Peki şunu söyeleyim.
L sütunda KALEM yazanlarıda getirecekmi.Yoksa Sadece B sütununda KALEM yazanlarımı getirecek.

 

[sinan05]

ama siz A1 hücresine KALEM yazmışsınız.Onun için KALEM getirdi.
A1 hücresine KALEM yerine DEFTER yazarsanız DEFTER i getirir.

Evet Hocam verilerin olduğu hücrelerin herhangibir hücresinde kalem yazıyorsa o satırı komple getirsin istiyorum. Böyle olunca kalemle ilgili bilgi alabiliyorum çok güzel ama ogün çıkış kısmındaki bilgilerden faydalanamıyorum.

 

[sinan05]

Peki şunu söyeleyim.
L sütunda KALEM yazanlarıda getirecekmi.Yoksa Sadece B sütununda KALEM yazanlarımı getirecek.

HOCAM B ve L sütunlarının sadece birinde de kalem yazssa her iki sütunda da kalem yazssa hiç farketmeksizin o satırı komple getirsin. Terside olabilir yani L de kalem yazar , B de silgi yazıyorsa iki veriyide hem silgiyi hemde kalemi getirsin

 

[Orion1]

Bunu deneyin.

Sub Tarihe_Gore_Ve_A1hucresine_gore_Veri_Getir()
Application.ScreenUpdating = False
Dim tarih1 As Date, tarih2 As Date, xtarih As Date, k As Range, var As Boolean
Dim S1 As Worksheet, S2 As Worksheet, Son As Long, Satır As Long
Worksheets("ANA SAYFA").Range("a4:U2000").ClearContents
tarih1 = Worksheets("ANA SAYFA").Range("a2").Value
tarih2 = Worksheets("ANA SAYFA").Range("b2").Value
Satır = 4
Set S1 = Sheets("ANA SAYFA")
Set S2 = Sheets("KAYITLAR")
S1.Select
    Satır = 4
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        For x = 4 To Son
            xtarih = S2.Cells(x, "A").Value
            If xtarih >= tarih1 And xtarih <= tarih2 Then
                If InStr(1, S2.Cells(x, "B").Value, Range("A1").Value) > 0 Then
                    S2.Range("A" & x & ":U" & x).Copy
                    S1.Cells(Satır, 1).PasteSpecial xlPasteAll
                    Satır = Satır + 1
                End If
            End If
        Next x
Range("A4").Select
Application.ScreenUpdating = True
MsgBox "bitti"
End Sub