Eğer koşulu oluşturma

Orion1 · 15 Haziran 2019

Hem B de Hemde L de kalem varsa 2 satırıda alt alta getiriyor.
Başka ne yapılır bilmiyorum.

Buyurun.

Kod:

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
                    Cells(Satır, "A").Value = S2.Cells(x, "A").Value
                    Satır = Satır + 1
                End If
                If InStr(1, S2.Cells(x, "L").Value, Range("A1").Value) > 0 Then
                    S2.Range("A" & x & ":U" & x).Copy
                    S1.Cells(Satır, "A").PasteSpecial xlPasteAll
                    Satır = Satır + 1
                End If
            End If
        Next x
Range("A4").Select
Application.ScreenUpdating = True
MsgBox "bitti"
End Sub

sinan05 · 15 Haziran 2019

Tamamdır HOCAM harikasınız böylede süper oldu dediğiniz gibi her ikisinde olunca iki tane getiriyor ama ziyanı yok yeterki bilgiyi göreyim. bundan daha iyisi olamaz çünkü benim istediğim aslında kendi içinde çelişiyor ama siz harkülade yaptınız. Herzaman duacınız olucam. belki ilerde makronun sonuna aynı olan satırlardan birini kaldırması için ek makro veya kodlar eklenebilir belki. ALLAH RAZI OLSUN tekrar hocam vaktinizi aldım elinize emeğinize sağlık.

sinan05 · 15 Haziran 2019

Orion1' Alıntı:

Hem B de Hemde L de kalem varsa 2 satırıda alt alta getiriyor.
Başka ne yapılır bilmiyorum.

Buyurun.

Kod:

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
                    Cells(Satır, "A").Value = S2.Cells(x, "A").Value
                    Satır = Satır + 1
                End If
                If InStr(1, S2.Cells(x, "L").Value, Range("A1").Value) > 0 Then
                    S2.Range("A" & x & ":U" & x).Copy
                    S1.Cells(Satır, "A").PasteSpecial xlPasteAll
                    Satır = Satır + 1
                End If
            End If
        Next x
Range("A4").Select
Application.ScreenUpdating = True
MsgBox "bitti"
End Sub

Tamamdır HOCAM harikasınız böylede süper oldu dediğiniz gibi her ikisinde olunca iki tane getiriyor ama ziyanı yok yeterki bilgiyi göreyim. bundan daha iyisi olamaz çünkü benim istediğim aslında kendi içinde çelişiyor ama siz harkülade yaptınız. Herzaman duacınız olucam. belki ilerde makronun sonuna aynı olan satırlardan birini kaldırması için ek makro veya kodlar eklenebilir belki. ALLAH RAZI OLSUN tekrar hocam vaktinizi aldım elinize emeğinize sağlık.

Orion1 · 15 Haziran 2019

Rica ederim.
İyi çalışmalar.

sinan05 · 15 Haziran 2019

Orion1' Alıntı:
Rica ederim.
İyi çalışmalar.

Tekrar tekrar teşekkürler sağolun Hocam iyi çalışmalar başarılar dilerim.

Korhan Ayhan · 17 Haziran 2019

Merhaba,

Evren bey konu için çözüm sunmuş. Alternatif olarak aşağıdaki kodu deneyebilirsiniz.

Aynı satırda bulunan verilerin mükerrer aktarılmaması için ilgili satırın yanına ayrıştırıcı bir ibare eklemek mantıklı bir çözüm olabilir.

Aşağıdaki kod veriyi aktarırken "AA" sütununa kırmızı renk veriyor. Böylece aranan veri ilgili satırın hem "B" hem "L" sütununda geçse bile bir kez aktarılmaktadır.

Umarım işinize yarar.

Kod:

Option Explicit

Sub Tarihe_ve_Kritere_Gore_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Ilk_Tarih As Date, Son_Tarih As Date, Aranan As String
    Dim Bul As Range, Adres As String, Satir As Long, Say As Long
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("KAYITLAR")

    S1.Range("A4:U" & S1.Rows.Count).ClearContents

    Ilk_Tarih = S1.Range("A2").Value
    Son_Tarih = S1.Range("B2").Value
    Aranan = S1.Range("A1").Value
   
    Set Bul = S2.Range("A:U").Find(Aranan, , , xlPart)
    If Not Bul Is Nothing Then
        Adres = Bul.Address
        Do
            If S2.Cells(Bul.Row, "A") >= Ilk_Tarih And S2.Cells(Bul.Row, "A") <= Son_Tarih Then
                If S2.Range("AA" & Bul.Row).Interior.Color <> 255 Then
                    Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row + 1
                    S1.Range("A" & Satir & ":U" & Satir).Value = S2.Range("A" & Bul.Row & ":U" & Bul.Row).Value
                    S2.Range("AA" & Bul.Row).Interior.Color = 255
                    Say = Say + 1
                End If
            End If
            Set Bul = S2.Range("A:U").FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
   
    S2.Range("AA:AA").Interior.Color = xlNone
   
    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "Aktarılan kayıt sayısı ; " & Say, vbInformation
End Sub

sinan05 · 17 Haziran 2019

Korhan Ayhan' Alıntı:

Merhaba,

Evren bey konu için çözüm sunmuş. Alternatif olarak aşağıdaki kodu deneyebilirsiniz.

Aynı satırda bulunan verilerin mükerrer aktarılmaması için ilgili satırın yanına ayrıştırıcı bir ibare eklemek mantıklı bir çözüm olabilir.

Aşağıdaki kod veriyi aktarırken "AA" sütununa kırmızı renk veriyor. Böylece aranan veri ilgili satırın hem "B" hem "L" sütununda geçse bile bir kez aktarılmaktadır.

Umarım işinize yarar.

Kod:

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Ilk_Tarih As Date, Son_Tarih As Date, Aranan As String
    Dim Bul As Range, Adres As String, Satir As Long, Say As Long
   
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("KAYITLAR")
   
    Ilk_Tarih = S1.Range("A2").Value
    Son_Tarih = S1.Range("B2").Value
    Aranan = S1.Range("A1").Value
   
    Set Bul = S2.Range("A:U").Find(Aranan, , , xlPart)
    If Not Bul Is Nothing Then
        Adres = Bul.Address
        Do
            If S2.Cells(Bul.Row, "A") >= Ilk_Tarih And S2.Cells(Bul.Row, "A") <= Son_Tarih Then
                If S2.Range("AA" & Bul.Row).Interior.Color <> 255 Then
                    Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row + 1
                    S1.Range("A" & Satir & ":U" & Satir).Value = S2.Range("A" & Bul.Row & ":U" & Bul.Row).Value
                    S2.Range("AA" & Bul.Row).Interior.Color = 255
                    Say = Say + 1
                End If
            End If
            Set Bul = S2.Range("A:U").FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
   
    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
   
    MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "Aktarılan kayıt sayısı ; " & Say, vbInformation
End Sub

Korhan Ayhan ve Evren hocam çok çok teşekkür ederim ALLAH RAZI OLSUN böyle çok süper odu eksik olmayın. Bende konu kapanmıştı diye düşünüyordum yine çözüm buldunuz . Bende excelde özelliklere bakarken yeninenleri kaldır özelliği gördüm onu makro kaydederek kodlara çevirdim Orion1 Hocamın yaptığı makronun sonuna eklemiştim kodlarda bu;
Range("A4:U2000").Select
Selection.UnMerge
ActiveSheet.Range("$A$4:$U$2000").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7 _
, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21), Header:=xlNo
Sheets("KAYITLAR").Select
Cells.Select
Selection.copy
Sheets("ANA SAYFA").Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("B4:J4").Select

fakat böyle çok daha güzel oldu. Tekarar sağolun.

sinan05 · 17 Haziran 2019

Korhan Ayhan' Alıntı:

Merhaba,

Evren bey konu için çözüm sunmuş. Alternatif olarak aşağıdaki kodu deneyebilirsiniz.

Aynı satırda bulunan verilerin mükerrer aktarılmaması için ilgili satırın yanına ayrıştırıcı bir ibare eklemek mantıklı bir çözüm olabilir.

Aşağıdaki kod veriyi aktarırken "AA" sütununa kırmızı renk veriyor. Böylece aranan veri ilgili satırın hem "B" hem "L" sütununda geçse bile bir kez aktarılmaktadır.

Umarım işinize yarar.

Kod:

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Ilk_Tarih As Date, Son_Tarih As Date, Aranan As String
    Dim Bul As Range, Adres As String, Satir As Long, Say As Long
   
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("KAYITLAR")
   
    Ilk_Tarih = S1.Range("A2").Value
    Son_Tarih = S1.Range("B2").Value
    Aranan = S1.Range("A1").Value
   
    Set Bul = S2.Range("A:U").Find(Aranan, , , xlPart)
    If Not Bul Is Nothing Then
        Adres = Bul.Address
        Do
            If S2.Cells(Bul.Row, "A") >= Ilk_Tarih And S2.Cells(Bul.Row, "A") <= Son_Tarih Then
                If S2.Range("AA" & Bul.Row).Interior.Color <> 255 Then
                    Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row + 1
                    S1.Range("A" & Satir & ":U" & Satir).Value = S2.Range("A" & Bul.Row & ":U" & Bul.Row).Value
                    S2.Range("AA" & Bul.Row).Interior.Color = 255
                    Say = Say + 1
                End If
            End If
            Set Bul = S2.Range("A:U").FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
   
    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
   
    MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "Aktarılan kayıt sayısı ; " & Say, vbInformation
End Sub

Korhan Hocam merek etmeden duramıyorum, bende sadece tarihe göre getirme kodları var ama sizin bu makronuz çok daha hızlı çalışıyor. Burdan A1 hücresine göre bul kısmını çıkartsak sadece tarihe göre getirse olabilirmi.

Korhan Ayhan · 17 Haziran 2019

Merhaba,

Sadece tarih aralığına göre aktarım için aşağıdaki kodu deneyiniz.

Ek olarak bir önceki mesajımda verdiğim koda küçük bir eski verileri temizleme kodu ekledim. Dilerseniz son halini kullanabilirsiniz.

Kod:

Option Explicit

Sub Tarihe_Gore_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Ilk_Tarih As Date, Son_Tarih As Date, Satir As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("KAYITLAR")
    
    S1.Range("A4:U" & S1.Rows.Count).ClearContents
    
    Ilk_Tarih = S1.Range("A2").Value
    Son_Tarih = S1.Range("B2").Value
    
    S2.Range("A3:U" & S2.Rows.Count).AutoFilter 1, Criteria1:=">=" & CLng(Ilk_Tarih), Operator:=xlAnd, Criteria2:="<=" & CLng(Son_Tarih)
    
    Satir = S2.Cells(S2.Rows.Count, 1).End(3).Row
    If Satir > 3 Then
        S1.Range("A4:U" & Satir).Value = S2.Range("A4:U" & Satir).Value
    End If
    
    On Error Resume Next
    S2.ShowAllData
    On Error GoTo 0
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "Aktarılan kayıt sayısı ; " & Satir - 3, vbInformation
End Sub

sinan05 · 17 Haziran 2019

Korhan Ayhan' Alıntı:
Sub Tarihe__Gore_Aktar() Dim S1 As Worksheet, S2 As Worksheet Dim Ilk_Tarih As Date, Son_Tarih As Date, Satir As Long Set S1 = Sheets("ANA SAYFA") Set S2 = Sheets("KAYITLAR") S1.Range("A4:U" & S1.Rows.Count).ClearContents Ilk_Tarih = S1.Range("A2").Value Son_Tarih = S1.Range("B2").Value S2.Range("A3:U" & S2.Rows.Count).AutoFilter 1, Criteria1:=">=" & CLng(Ilk_Tarih), Operator:=xlAnd, Criteria2:="<=" & CLng(Son_Tarih) Satir = S2.Cells(S2.Rows.Count, 1).End(3).Row If Satir > 3 Then S1.Range("A4:U" & Satir).Value = S2.Range("A4:U" & Satir).Value End If Set S1 = Nothing Set S2 = Nothing MsgBox "Aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _ "Aktarılan kayıt sayısı ; " & Satir - 3, vbInformation End Sub

Oh be Korhan hocam süper olmuş elinize sağık harikasınız sizlerin sayesinde bütün makrolar çok hızlı çalışıyor. Çok rahatladım ya eksik olmayın. Nacizane bende farketmiştim hocam kodların başına şunu ekledim
Application.ScreenUpdating = False
Worksheets("ANA SAYFA").Range("a4:U2000").ClearContents
Application.ScreenUpdating = True

Birde hocam yapmış olduğunuz makro ilk çalışmada kayıtlar sayfasına verilerin sağ tarafına bir sütuna kırmızı dolgu yapıyorya makroyu ikinci kez çalıştırınca hiçbir veri getirmiyordu. Bende kodların sonuna dolguyu kaldıracak biçimlendirme makrosu ekledim şimdi sorunsuz çalışıyor.
şu kodları ekledim;
Sheets("KAYITLAR").Select
Columns("AA:AA").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Sheets("ANA SAYFA").Select
Range("B4:J4").Select

Hocam birde anlayamadım zararı yok ama tüm verileri getirdiğim zaman kayıtlar sayfasından 63.satır veri alıyor ve 63. satırdan 11bin küsür satırı gizliyor 11binden sonra devam ediyor satırlar anlamadım şuan bir zararı yok ama..

Korhan Ayhan · 17 Haziran 2019

Doğru söylüyorsunuz kırmızı rengi sonradan kaldırmak fayda sağlayacaktır. Bende kendi mesajımdaki kodu revize ettim.

sinan05 · 17 Haziran 2019

Korhan Ayhan' Alıntı:
Doğru söylüyorsunuz kırmızı rengi sonradan kaldırmak fayda sağlayacaktır. Bende kendi mesajımdaki kodu revize ettim.

Aynen Hocam???? süper oldu herşey sayenizde çok çok teşekkürler. Saygı ve hürmetlerimi sunarım KORHAN Hocam

sinan05 · 17 Haziran 2019

Korhan Ayhan' Alıntı:
Doğru söylüyorsunuz kırmızı rengi sonradan kaldırmak fayda sağlayacaktır. Bende kendi mesajımdaki kodu revize ettim.

KORHAN Hocam ilaveten ben bu site de sizden ve Orion1 gibi diğer bir çok hocadan çok fayda ve yarar gördüm gördüm.Hep Kuru teşekkür olmaz benimde faydam olsun istiyorum ve makrolarla ilgili bir eğitim paketi satın almak istiyorum beni yönlendirirmisiniz lütfen.

Korhan Ayhan · 17 Haziran 2019

Sinan Bey,

Foruma katkı sağlamak ve forumdan daha fazla ek özellikleri ile faydalanmak için linki inceleyebilirsiniz.

https://www.excel.web.tr/threads/altin-ueyelik.57910/

sinan05 · 17 Haziran 2019

Korhan Ayhan' Alıntı:
Sinan Bey,

Foruma katkı sağlamak ve forumdan daha fazla ek özellikleri ile faydalanmak için linki inceleyebilirsiniz.

https://www.excel.web.tr/threads/altin-ueyelik.57910/

Tamamdır Hocam hemen inceliyorum.Bu arada Korhan Hocam son yazmış olduğunuz, sadece tarihe göre veri getirme makrosunda şu kodda; S2.Range("A3:U" & S2.Rows.Count).AutoFilter 1, Criteria1:=">=" & CLng(Ilk_Tarih), Operator:=xlAnd, Criteria2:="<=" & CLng(Son_Tarih) sanırım AutoFilter 1 ibaresi yüzünden diğer yaptığınız isme ve hem isme hem tarihe makroları hiç bir sonuç getirmemeye başladı bende kodların arasına filitreyi kaldırma kodu ekledim şimdilik sorun yok umarım doğru yapmışımdır.
kodların son hali böyle oldu;

S2.Range("A3:U" & S2.Rows.Count).AutoFilter 1, Criteria1:=">=" & CLng(Ilk_Tarih), Operator:=xlAnd, Criteria2:="<=" & CLng(Son_Tarih)

Satir = S2.Cells(S2.Rows.Count, 1).End(3).Row
Sheets("KAYITLAR").Select
Selection.AutoFilter

If Satir > 3 Then
S1.Range("A4:U" & Satir).Value = S2.Range("A4:U" & Satir).Value
End If

Set S1 = Nothing
Set S2 = Nothing
Sheets("ANA SAYFA").Select
Range("B4:J4").Select
Application.ScreenUpdating = True
End Sub

Korhan Ayhan · 17 Haziran 2019

İki kodu farklı değerlendirince bazı eksiklikler olabiliyor. Sizin hatırlatmanız üzerine bende önerdiğim kodları revize ettim.

sinan05 · 17 Haziran 2019

Korhan Ayhan' Alıntı:
İki kodu farklı değerlendirince bazı eksiklikler olabiliyor. Sizin hatırlatmanız üzerine bende önerdiğim kodları revize ettim.

Anladım Hocam ben teste devam ediyorum teşekkürler.

sinan05 · 18 Haziran 2019

Korhan Ayhan' Alıntı:
İki kodu farklı değerlendirince bazı eksiklikler olabiliyor. Sizin hatırlatmanız üzerine bende önerdiğim kodları revize ettim.

KORHAN Hocam tekrar merhabalar. Müsait olduğunuzda aşağıdaki yaptığınız makroyu biraz revize edebilirmiyiz. Yapmak istediğim sogulayınca anasayfa ya gelen veriler tarihe göre gruplanabilirmi. Mesela 01.02.2017 tarihli 2 adet satır geliyor sonra 02.02.2017 tarihli 4 adet satır geliyor. 1 ne olan veriler bitince bir satır boş bırakıp 2 sine olan veriler gelse çok güzel olacak. birde C hücresi C ve T hücrelerinin birleşiminden oluşuyor yeni satır eklenince bu hücreler ayrılıyor bunu da çözemedim.

Sub isme_Gore_Veri_Getir_Hizli()
Application.ScreenUpdating = False
Dim S1 As Worksheet, S2 As Worksheet
Dim Bul As Range, Adres As String, Satir As Long, Say As Long
Set S1 = Sheets("ANA SAYFA")
Set S2 = Sheets("KAYITLAR")
S1.Range("A4:U" & S1.Rows.Count).ClearContents

Aranan = S1.Range("A1").Value
Set Bul = S2.Range("A:T").Find(Aranan, , , xlPart)
If Not Bul Is Nothing Then
Adres = Bul.Address
Do
Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row + 1
S1.Range("A" & Satir & ":U" & Satir).Value = S2.Range("A" & Bul.Row & ":U" & Bul.Row).Value
Say = Say + 1
End If
Set Bul = S2.Range("A:T").FindNext(Bul)
Loop While Not Bul Is Nothing And Bul.Address <> Adres
End If
Set Bul = Nothing
Set S1 = Nothing
Set S2 = Nothing
Application.ScreenUpdating = True
Sheets("ANA SAYFA").Select
Range("A4").Select
End Sub

Korhan Ayhan · 24 Haziran 2019

Merhaba,

Tarihler karışık geldiğin için ilk önce makro sonunda sıralamak gerekiyor. Sonrasında döngüye alınarak aralarına bir boş satır eklenebilir.

Fakat bu işlemin olması için birleştirilmiş hücre kullanımından vazgeçmeniz gerekiyor.

sinan05 · 25 Haziran 2019

Korhan Ayhan' Alıntı:
Merhaba,

Tarihler karışık geldiğin için ilk önce makro sonunda sıralamak gerekiyor. Sonrasında döngüye alınarak aralarına bir boş satır eklenebilir.

Fakat bu işlemin olması için birleştirilmiş hücre kullanımından vazgeçmeniz gerekiyor.

Teşekkür ederim KORHAN Hocam. Sağolsun sizin gibi yardım sever bir Hocam aşağıda ki şekilde yaptı. Teşekkürler döndüğünüz için.
Sub SIRALAMA()
Dim S3 As Worksheet: Dim i As Integer
Set S3 = Sheets("ANA SAYFA")
Application.ScreenUpdating = False
Son = S3.Cells(65355, "A").End(3).Row
S3.Range("A4:U" & Son).MergeCells = False
S3.Range("A4:U" & Son).Sort Range("A4"), xlAscending
For i = Son To 4 Step -1
S3.Range(S3.Cells(i, "C"), S3.Cells(i, "T")).MergeCells = True
If S3.Range("A" & i).Value < S3.Range("A" & i + 1) Then
S3.Rows(i + 1).Insert Shift:=xlDown = xlLeft
S3.Range(S3.Cells(i + 1, "C"), S3.Cells(i + 1, "T")).MergeCells = True
S3.Cells(i + 1, "B") = "SON"
i = i + 1
End If
Next
Application.ScreenUpdating = True
End Sub

Eğer koşulu oluşturma

Orion1

Uzman

sinan05

sinan05

Orion1

Uzman

sinan05

Korhan Ayhan

Administrator

sinan05

sinan05

Korhan Ayhan

Administrator

sinan05

Korhan Ayhan

Administrator

sinan05

sinan05

Korhan Ayhan

Administrator

sinan05

Korhan Ayhan

Administrator

sinan05

sinan05

Korhan Ayhan

Administrator

sinan05