Liste Oluşturma, Karışık Verilerden

[1Al2Ver]

Merhaba,

Farklı sayfada, 2 sütunda olan verileri, diğer sayfada, seçime göre, alt alta almak istiyorum,

Ek'li dosyamda, geniş açıklama ve örnek bulunmaktadır.

Teşekkür ederim.

 

[1Al2Ver]

Merhaba,

Önce, ilgili hücrelere düşeyara formülü yazdım,

Sonrasında, Makro Kaydet ile ilgili hücrelerdeki formülleri kayıt ettim, tabi 18 tane IF oldu, ancak çözüm de oldu.

Bu makro nasıl kısaltıla bilir ?

Teşekkür ederim.

Sub DÜŞEYARA()
'
' DÜŞEYARA Makro
'

'
    Application.CutCopyMode = False
   
    Range("AC2").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC3").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC4").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC5").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC6").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC8").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC9").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC10").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC11").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC12").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC13").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC14").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC15").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC16").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC17").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC18").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC19").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(KARŞILAŞMA_LİSTESİ!RC[27]<>KARŞILAŞMA_LİSTESİ!R1C56,KARŞILAŞMA_LİSTESİ!RC[27],KARŞILAŞMA_LİSTESİ!RC[28])"
    Range("AC20").Select
End Sub

 

[Ömer]

Merhaba,

Deneyiniz.

Sub bul_getir()
  
    Dim S1 As Worksheet, sat As Long, c As Range, Adr As String, s As Integer
  
    Set S1 = Sheets("KARŞILAŞMA_LİSTESİ")
  
    Application.ScreenUpdating = False
    Sheets("SİSTEM_VERİLERİ").Select
    Range("AA2:AA20").ClearContents
  
    sat = 2
    Set c = S1.[BD:BE].Find(S1.[BD1], , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            s = -1
            If c.Column = 56 Then s = 1
            Cells(sat, "AA") = S1.Cells(c.Row, c.Column).Offset(0, s)
            sat = sat + 1
            Set c = S1.[BD:BE].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If

    Application.ScreenUpdating = True
  
End Sub

 

[1Al2Ver]

Sayın Ömer merhaba,

İlginiz ve çözüm için çok teşekkür ederim, kod sorunsuz çalışıyor.

Saygılarımla.