Saygıdeğer @berduş Hocam

Nazik yardımlarınız için teşekkür ediyorum. Yapmak istediğimi şöyle ifade etmeye çalışayım Hocam:
IVL analizleri bizim elimizde mevcut, proje kapsamında bize kullanılması talep edilen IVL'ler liste halinde sadece IVL no ve kısa adı diyebileceğimiz açıklaması ve birimi ile bildirilir. Bizim bu IVL'lere ilişkin analiz bilgilerini işlememiz ve ilgili departmanların kullanacağı referans dosyası olarak hazırlamamız istenir. İstenen IVL bir kaç tane olduğunda sorun teşkil etmese de projelerin büyük çoğunluğunda yüzlerce bazen binlerce IVL bildirildiğinden bu iş inanılmaz zaman kaybına sebep oluyor. Bu nedenle böyle bir çalışma yapmaya niyetlenip başarılı olamayınca yardımlarınızı rica etmiştim.
Aslında elimizdeki dosya ekteki örnekteki IVL sayfasından ibaret sadece. Arama sayfası sizin yardımız ile bu IVL sayfasından tek hücre için yaptığımız aramayı listeleyen sayfa. Eklenen Tum_sayfa adlı sayfa bize diğer departmandan gelen IVL listesi ve biz bunların analizlerini bir bütün halinde listelemeye çalışıyoruz. Ben Gelen IVL listesini Tum_sayfa adlı sayfaya kopyaladığımı ve sizin varsayımınızdan hareket ile Analiz Listele adlı butona tıkladığımızda elde edilmesi gereken sonucu Sonuc sayfasına ekleyerek yeni örneği ekledim.

İlk defa böyle bir işlem yapmaya çalıştığım için yeteri kadar açıklayamamış olabilirim örnek içinde ilgili sayfalarda da notlarım mevcuttur Hocam. Zahmetler verdiğim için özür dileyerek, nazik yardımlarınız için bir kez daha şükranlarımı sunuyorum.

Saygılarımla

Murtaza AF

Ekledigim kodları denediniz mi? yanlış yorumlamış olabilirim ama eklediğim kod tam olarak sizin istediğiniz gibi çalışmıyor mu?
sadece arada fazladan bir boşluk var o da kaldırılabilir.

peki gösterdiğiniz gibi renkli mi olacak?

şimdi anladığım kadarını söyleyeyim
1 - tam_sayfada IVL listesi var ve biz bu sayfadaki butona basınca
2 - IVL sayfasından ilgili verileri bulacak ve
3 - sonuç sayfasına aktaracak öyle mi?
bizim dikkat etmemiz gereken tek nokta koyu IVL NO değerleri mi? ya listedeki IVL NO yoksa uyarı falan mı verecek ne yapacak?

Hocam sonuç olarak ayrı bir sayfaya getirmek daha kolaysa ayrı sayfaya getirelebilir, renkli olması da gerekli değil. Ben gelen listede butona tıklandığında nasıl bir sonuç almamız gerekiyor sonuc adlı sayfada onu gösterdim ve taşınan satırları ve eklenen açıklamaları zincirleme gösterebilmek için renklendirme kullandım. atoykan Hocam en azından nasıl bir sonuc almak istediğinizi gösterin ona göre çalışalım öğüdüne istinaden öyle anlatmaya çalıştım. Bildirilen IVL'lerin bulunmaması mümkün değil Hocam. Bunlar standart ve resmi bilgiler olup elle yazılmıyor işaretlenen IVL'ler rapor olarak olarak çıkartılıp bize gönderiliyor.

dilerim işinize yarar
Modül kodları:
1 - tek veri değişimindeki B2 hücresi değişince çalışacak kod

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("b2")) Is Nothing Then TekVeriAl (Target.Value) 'B2 değişince tetiklenir

End Sub

2 - Tüm sayfasındaki verileri düzenleme kodu

Sub DiziyeAl()

Dim ShtAna As Worksheet

Dim ShtHdf As Worksheet

Dim RngAna As Range



Set ShtAna = ThisWorkbook.Sheets("IVL")

Set ShtHdf = ThisWorkbook.Sheets("Tum_Sayfa")



Set RngAna = ShtAna.Range("A:A")

Set RngAna = RngAna.Worksheet.Range("A2:" & RngAna.Rows(RngAna.Rows.Count).End(xlUp).Address(0, 0))

SonStr = RngAna.Rows(RngAna.Rows.Count).Row



Set AdrsDz = New Collection

For Each Hucr In RngAna

    If Hucr.Font.Bold = True And IsNumeric(Hucr.Value) = True Then

        AdrsDz.Add Int(Hucr.Row)

    End If

Next Hucr



VeriAlStr = veriAl

RngKopya = ""

HcrYukseklik = ""

For x = 1 To AdrsDz.Count

    If InStr(VeriAlStr, ":" & Replace(ShtAna.Range("A" & AdrsDz(x)), ".", "") & ":") > 0 Then

        If x = AdrsDz.Count Then RngBit = SonStr Else RngBit = AdrsDz(x + 1) - 2

        RngBit = ShtAna.Range("l" & RngBit).End(xlUp).Row + 1

        RngKopya = RngKopya & "," & ShtAna.Range("A" & AdrsDz(x)).Address & ":" & ShtAna.Range("O" & RngBit).Address

        HcrYukseklik = HcrYukseklik & "," & RngBit

    End If

Next x

'hy_____________________________________Sil

    With ShtHdf

    LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row + 10

        .Range("A2:O" & LastRow).UnMerge

        .Range("A2:O" & LastRow).Clear

        .Cells.UseStandardHeight = True

        .Cells.UseStandardWidth = True

'hy_____________________________________kopyalama

    RngKopya = Mid(RngKopya, 2)

        ShtAna.Range(RngKopya).Copy

        .Range("D2").PasteSpecial xlPasteAll





For x = 2 To SonStr

    If .Range("D" & x).Font.Bold = True And IsNumeric(.Range("D" & x).Value) = True Then

'        .Range("D" & x).Copy

'        .Range("A" & x).PasteSpecial xlPasteAll

'

'        .Range("E" & x).Copy

'        .Range("B" & x).PasteSpecial xlPasteAll



'        .Range("O" & x).Copy

'        .Range("C" & x).PasteSpecial xlPasteAll

        .Range("A" & x).Value = .Range("D" & x).Value

        .Range("B" & x).Value = .Range("E" & x).Value

        .Range("C" & x).Value = .Range("O" & x).Value

        .Range("A" & x).BorderAround LineStyle:=xlContinuous, Weight:=xlThin

        .Range("B" & x).BorderAround LineStyle:=xlContinuous, Weight:=xlThin

        .Range("C" & x).BorderAround LineStyle:=xlContinuous, Weight:=xlThin

    End If

Next x





End With

'hy_______________________________________________________



HcrYukseklik = Mid(HcrYukseklik, 2)



YukseklikDizi = Split(HcrYukseklik, ",")

With ShtHdf

SonStr = .Range("D" & .Rows.Count).End(xlUp).Row

y = 0

For x = 3 To SonStr

    If .Range("D" & x).Font.Bold = True And IsNumeric(.Range("D" & x).Value) = True Then

        .Range("D" & x - 1).RowHeight = ShtAna.Range("O" & YukseklikDizi(y)).RowHeight

        y = y + 1

    End If

Next x

.Range("D" & SonStr).RowHeight = ShtAna.Range("O" & YukseklikDizi(y)).RowHeight





For x = 1 To 15

    .Columns(x + 3).ColumnWidth = ThisWorkbook.Sheets("IVL").Columns(x).ColumnWidth

Next x

    .Columns(1).ColumnWidth = 10.14

    .Columns(2).ColumnWidth = 105.14

    .Columns(3).ColumnWidth = 9.14

    .Columns("A:C").Font.Bold = True

    .Columns(1).NumberFormat = "#,##0"



End With



Application.CutCopyMode = False

End Sub

3 - Tüm sayfasında yer alan IVL No değerlerini alma kodu

Function veriAl() As String

Set Sht = ThisWorkbook.Sheets("Tum_Sayfa")

    SonStr = Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row

Set Rng = ThisWorkbook.Sheets("Tum_Sayfa").Range("A2:A" & SonStr)



For Each Hucr In Rng

    veriAl = veriAl & ":" & Replace(Hucr.Rows, ".", "")

Next Hucr

veriAl = veriAl & ":"

End Function

4 - tek veri bulup değiştirme kodu (Arama Sayfasındaki)

Sub TekVeriAl(ByVal txtAranan As String) 'TekVeriAl("15.100.1005")



Dim ShtAna As Worksheet

Dim ShtHdf As Worksheet

Dim RngAna As Range



txtAranan = Replace(txtAranan, ".", "")

Set ShtAna = ThisWorkbook.Sheets("IVL")

Set ShtHdf = ThisWorkbook.Sheets("Arama")



Set RngAna = ShtAna.Range("A:A")

Set RngAna = RngAna.Worksheet.Range("A2:" & RngAna.Rows(RngAna.Rows.Count).End(xlUp).Address(0, 0))

SonStr = RngAna.Rows(RngAna.Rows.Count).Row



For Each Hucr In RngAna

    If Hucr.Font.Bold = True And IsNumeric(Hucr.Value) = True And Replace(Hucr.Value, ".", "") = txtAranan Then

        BasStr = Int(Hucr.Row)

        Exit For

    End If

Next Hucr



For x = BasStr + 1 To SonStr

    If ShtAna.Range("A" & x).Font.Bold = True And IsNumeric(ShtAna.Range("A" & x).Value) = True Then

        BitStr = x

        Exit For

    End If

Next

SonStr = ShtAna.Cells(x - 1, "L").End(xlUp).Row

BitStr = SonStr + 1

Set RngCopy = ShtAna.Range("A" & BasStr & ":O" & BitStr)



With ShtHdf

SonStrHdf = .Cells(.Rows.Count, "C").End(xlUp).Row

    .Range("C:Q").EntireColumn.Delete

    .Cells.RowHeight = 15

RngCopy.Copy

    .Range("C2").PasteSpecial xlPasteAll

For x = 1 To 15

    .Columns(x + 2).ColumnWidth = ShtAna.Columns(x).ColumnWidth

Next x

    .Columns("A:C").Font.Bold = True

    .Columns(1).NumberFormat = "#,##0"

    .Range("A" & SonStrHdf).RowHeight = ShtAna.Range("A" & BitStr).RowHeight

End With



Application.CutCopyMode = False

End Sub