Data dan istenen satırları başka sekmeye çağırmak

[sati]

Değerli Üstadlar,

Çok fazla zamanımı alan bir rapor için sizden yardımlarınızı rica ediyorum. Ekteki excel doyasının 1. sekmesinde (DATA) bulunan verilerden sadece istediğim bazı satırları 2. sekmeye getirmek istiyorum. Ekteki listede örnek sadece 4-5 kontenjan gönderdim. normalde 200 e yakın farklı kontenjan olduğu için tek tek yapmak çok uzun sürüyor. vlookup ve hlookup formülleri ile bişeyler yapmaya çalıştım ama malesef bi sonuca ulaşamadım.

Yardımlarınız için şimdiden çok teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Çalışmanıza birde "RAPOR" isimli bir sayfa ekleyin ve aşağıdkai kodu çalıştırın.

Option Explicit
 
Sub ÖZET_RAPOR()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long
    Dim BUL As Range, ADRES As String, Satır As Long, X As Long
 
    Application.ScreenUpdating = False
 
    Set S1 = Sheets("DATA")
    Set S2 = Sheets("RAPOR")
 
    S2.Cells.Delete
    Satır = 1
 
    Son = S1.Cells(Rows.Count, 1).End(3).Row
    Set BUL = S1.Cells.Find("HOTEL", S1.Cells(Son, 1), , xlPart)
    If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
            S2.Cells(Satır, 1) = BUL.Value
 
            For X = BUL.Row + 2 To BUL.Row + 49
                If S1.Cells(X, 1) = "Commitment" Then
                    S1.Cells(X, 1).EntireRow.Copy S2.Cells(Satır + 1, 1)
                    Satır = Satır + 1
                End If
                If S1.Cells(X, 1) = "Used" Then
                    S1.Cells(X, 1).EntireRow.Copy S2.Cells(Satır + 1, 1)
                    Satır = Satır + 2
                    Exit For
                End If
            Next
 
            Set BUL = S1.Cells.FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    End If
    S2.Select
    S2.Range("A1").Select
    S2.Cells.EntireColumn.AutoFit
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[sati]

Korhan Bey çok teşekkür ederim. Tam olarak istediğim format bu şekildeydi. Emeğinize sağlık. Sizden bir tek ricam olacak. Bütün otel isimlerinde "Hotel" ibaresi bulunmadığı için makro sadece "Hotel" yazanları süzüyor. Her grubun bir başka ortak noktasıda A1 sütunundaki her otel isminin altındaki hücrenin boş olması. Acaba bunu "Hotel" e göre değilde, "a1 sütunundaki boş hücrenin bir üstündeki" şeklinde yazabilir miyiz?

 

[Korhan Ayhan]

Merhaba,

Peki "Allocation total" ifadesi her otel verilerinin altında var mı?

 

[sati]

evet var, 1.satır: otel ismi, 2. satır: boş, 3.satır:allocation total. Bunlar sabit...

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub ÖZET_RAPOR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim BUL As Range, ADRES As String
    Dim Satır As Long, X As Long
    
    Application.ScreenUpdating = False
        
    Set S1 = Sheets("DATA")
    Set S2 = Sheets("RAPOR")
    
    S2.Cells.Delete
    Satır = 1
    
    Set BUL = S1.Range("A:A").Find("Allocation total", , , xlWhole)
    If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
            S2.Cells(Satır, 1) = BUL.Offset(-2, 0).Value
            
            For X = BUL.Row + 1 To BUL.Row + 50
                If S1.Cells(X, 1) = "Commitment" Then
                    S1.Cells(X, 1).EntireRow.Copy S2.Cells(Satır + 1, 1)
                    Satır = Satır + 1
                End If
                If S1.Cells(X, 1) = "Used" Then
                    S1.Cells(X, 1).EntireRow.Copy S2.Cells(Satır + 1, 1)
                    Satır = Satır + 2
                    Exit For
                End If
            Next
            
            Set BUL = S1.Range("A:A").FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    End If
 
    S2.Select
    S2.Range("A1").Select
    S2.Cells.EntireColumn.AutoFit
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[sati]

Korhan Bey, ellerinize sağlık. Beni nasıl bir zahmetten kurtardınız anlatamam. Tam istediğim gibi olmuş makro. Kusursuz bi şerkilde çalışıyor.