Soru Koşula Bağlı Olarak Sayfadan Sayfaya Bilgi Aktarımı

[zozotr]

Merhabalar üstadlarım;

Benim için zor ama sizler için sanırım basit olan bir bilgi almak istiyorum.
Eklediğim örnek dosyada Liste Sayfasında bulunan REZ NO daki değerin RAPOR sayfasında bilgi olarak yazılmasını istiyorum.
Bunu kendim düşeyara ile yapabilirim. Ama yapamadığım kısım LİSTE sayfasındaki ODA Noya ait Giriş ve Çıkış verilerinin RAPOR sayfasında sayfasındaki tarihlerin altına işlenmesi.

Tabiki burada sadece örnek dosya olduğu için az satır ve az sütün var. Dolayısıyla çok daha fazla data var. kendime göre sizlerin yardımıyla şekillendireceğim.
Tabloda boyalı olanları kendim yaptım. Olmasını istediğim şekilde. 3. ve 4. sıradakiler için sizlerden rica da bulunuyorum.

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

 

[Ömer]

Merhaba,

Veri sayınız fazla ise makro kullanmakta fayda var. Hem soru yapısı makro ile çözüme daha uygun gibi.

1)Rapor sayfasının ölçütlerini siz mi belirliyorsunuz. Örneğin liste sayfasındaki giriş çıkış tarihi rapor sayfasındaki tarihlerin dışında kalırsa ne oluyor.
2)Yine aynı şekilde rapor sayfasında oda numaları sabit mi, yoksa liste sayfasında hangi odalar mevcuttsa onlarmı raporlanacak.

 

[zozotr]

Ömer Bey geri dönüşünüz için teşekkür ederim.

1- Rapor Sayfasındaki verileri Liste sayfasından çekecek.
2- Rapor sayfasında oda numaraları sabit tabloda. Bu odaların karşılığına Liste sayfasındaki veriler çekilecek.

Önerinizi bekliyorum.
Dosyada belirtmeye çalıştım.
Teşekkür ederim.

 

[Ömer]

Deneyiniz.
Yalnız, 2 sorunuzun cevabına istinaden oda no. sütunu sabit olduğu için aynı tarihte aynı odaya ait rez. olursa üzerine yazacaktır.

Sub test()

    Dim S1 As Worksheet, S2 As Worksheet, Wf As WorksheetFunction
    Dim mn As Double, mx As Double, ms As Double, i As Long, c As Range, s As Integer, j As Long
  
    Set S1 = Sheets("LİSTE")
    Set S2 = Sheets("RAPOR")
    Set Wf = WorksheetFunction
  
    mn = Wf.Min(S1.[K:L])
    mx = Wf.Max(S1.[K:L])
    ms = mx - mn + 1
  
    Application.ScreenUpdating = False
    S2.Select
    Range("C:IV").Delete
    Rows(1).NumberFormat = "d/m"
  
    Range("C1") = mn
    Range("C1").Resize(1, ms).DataSeries xlRows, xlChronological, xlDay, 1
  
    For i = 2 To S1.Cells(Rows.Count, "E").End(xlUp).Row
        Set c = [A:A].Find(S1.Cells(i, "E"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            If S1.Cells(i, "K") <> "" Then
                s = Wf.Match(S1.Cells(i, "K"), S2.Rows(1), 0)
                For j = S1.Cells(i, "K") To (S1.Cells(i, "L") - 1)
                    Cells(c.Row, s) = S1.Cells(i, "C")
                    s = s + 1
                Next j
            End If
        End If
    Next i
  
    Range("A1").CurrentRegion.Borders.LineStyle = 1
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True
  
End Sub

 

[zozotr]

Ömer Bey
Cevap için teşekkür ederim.
Kodlar çalışıyor fakat şöyle bir durum söz konusu.
Makro çalıştıktan sonra RAPOR sayfasını biçimlendiriyor.
Yeni tablo oluşturuyor. Ben bu makroyu bir güncelleme gibi kullanmak istiyorum. Yani seçilen tarihlerde kaç boş oda kaldı onu görmek istiyorum aslında. Sayfayı silmese ve eski veri üzerinde kalsa da görsem olabilir mi? Makroyu çalıştırınca biçimleme yapmasın. Rapor sayfası sabit kalsın.
Teşekkür ederim

 

[Ömer]

İlk mesajımda tarihlerle ilgili sorumu bu yüzden sormuştum.
Deneyiniz. Eğer istediğiniz bu değilse gerçek tablonuzla örtüşen ve veri sayısı daha fazla olan yeni bir örnek dosya hazırlayarak ekler misiniz.
Ayrıca oda numaralarının her iki sayfada aynı olduğunu kontrol ediniz. Z-03 ve Z03 gibi, - karakteri birinde yok. Eşit olmazsa eşleşme yapmaz.

Sub test()

    Dim S1 As Worksheet, S2 As Worksheet, Wf As WorksheetFunction
    Dim i As Long, c As Range, s As Integer, j As Long
 
    Set S1 = Sheets("LİSTE")
    Set S2 = Sheets("RAPOR")
    Set Wf = WorksheetFunction
 
    Application.ScreenUpdating = False
    S2.Select
 
    For i = 2 To S1.Cells(Rows.Count, "E").End(xlUp).Row
        Set c = [A:A].Find(S1.Cells(i, "E"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            If S1.Cells(i, "K") <> "" Then
                s = Wf.Match(S1.Cells(i, "K"), S2.Rows(1), 0)
                For j = S1.Cells(i, "K") To (S1.Cells(i, "L") - 1)
                    Cells(c.Row, s) = S1.Cells(i, "C")
                    s = s + 1
                Next j
            End If
        End If
    Next i

    Application.ScreenUpdating = True
 
End Sub

 

[zozotr]

Değerli Üstadım Ömer Bey;

Yukarıda yazdığınız kod işime yaradı. Saat itibarıyla tek kontrol yapabildim. Yarın gün içinde yine kontrol edeceğim daha geniş bir liste ile.
Emekleriniz için çok teşekkür ederim.

Esen kalın.

 

[zozotr]

Ömer Hocam Tekrar Selamlar;

Yukarıda verdiğiniz kodu uzun süredir kullanıyorum. Emeğinize sağlık. O tarihten bu yana hata vermedi. Ama bugün itibarıyla Type 13 Missmatch hatası veriyor. Kodu kendime göre şekillendirmiştir. Bu sorunun kaynağı ne olabilir acaba.
Değerler normal. Arayıp bulup eşleştirmesi gereken tüm bilgiler var ama malesef hata alıyorum.
Rica etsem tekrar bakma şansınız olur mu?
Dosyayı tekrar ekliyorum.

şimdiden teşekkür ederim.

 

[zozotr]

Teşekkür ederim. Sorun benden kaynaklıymış.
Ömer Bey mesajı editleyemedim. Ama sorunun kaynağını buldum.
Tekrar emeklerinize sağlık.