Soru Ayrı sayfalardaki hücrelerden veri alma

[hadromer]

Merhaba,
Bir dosya içerisinde birden çok sayfada veri içeren dosyam var.
bu dosya içerisindeki verileri aynı sayfaya bir kurala göre almak istiyorum.
Fotoğrafta görüldüğü üzere 1-5 arası bolluk başlığı var. öncelikle Hangi numara x ile işaretlenmişse x yerine o numara yazılmasını istiyorum .
verileri de sayfanın adına göre a ve b sütunlarını dahil ederek örnek dosyadaki gibi almak istiyorum. sayfa ismi birleşirken üstte yer alacak
yardımcı olursanız çok sevinirim.
iyi akşamlar dilerim.
Örnek Dosya : https://dosya.org/J56oQ

 

[Korhan Ayhan]

Merhaba,

Dosyanızı farklı bir siteye yükleyebilir misiniz?

 

[hadromer]

Merhaba,

Dosyanızı farklı bir siteye yükleyebilir misiniz?

Merhaba Korhan Bey,
Buyrun farklı siteye yükledim. Teşekkür ederim.

ornek_dosya.xlsx dosyasını indir - download

ornek_dosya.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

 

[ÖmerFaruk]

Merhaba, Aşağıdkai kodu bir module içine ekleyip, rapor sayfasında makroyu çalıştırabilirsiniz.

Sub TekTabloYap()
    Dim Veri, Liste()
    Dim x As Integer, i As Integer, k As Byte, son As Integer
    Cells.Clear
    Range("A1") = "Takson"
    Range("B1") = "Teşhis"
    Kolon = 2
    For x = 1 To Worksheets.Count
        son = Worksheets(x).Range("A" & Rows.Count).End(3).Row
        If Worksheets(x).Range("C1") <> "Bolluk (Ki)" Or son < 4 Then GoTo Devam
        Kolon = Kolon + 1
        Veri = Worksheets(x).Range("A4:G" & son).Value
        ReDim Liste(1 To UBound(Veri), 1 To Worksheets.Count + 2)
        For i = 1 To UBound(Veri)
            Liste(i, 1) = Veri(i, 1)
            Liste(i, 2) = Veri(i, 2)
            For k = 3 To 7
                If Veri(i, k) = "x" Then
                    Liste(i, Kolon) = k - 2
                    Exit For
                End If
            Next k
        Next i
        Cells(1, Kolon) = Worksheets(x).Name
        son = Range("A" & Rows.Count).End(3).Row
        Range("A" & son).Offset(1, 0).Resize(UBound(Veri), Worksheets.Count + 2) = Liste
Devam:
    Next x
    Erase Liste: Erase Veri
End Sub

 

[hadromer]

Merhaba, Aşağıdkai kodu bir module içine ekleyip, rapor sayfasında makroyu çalıştırabilirsiniz.

Sub TekTabloYap()
    Dim Veri, Liste()
    Dim x As Integer, i As Integer, k As Byte, son As Integer
    Cells.Clear
    Range("A1") = "Takson"
    Range("B1") = "Teşhis"
    Kolon = 2
    For x = 1 To Worksheets.Count
        son = Worksheets(x).Range("A" & Rows.Count).End(3).Row
        If Worksheets(x).Range("C1") <> "Bolluk (Ki)" Or son < 4 Then GoTo Devam
        Kolon = Kolon + 1
        Veri = Worksheets(x).Range("A4:G" & son).Value
        ReDim Liste(1 To UBound(Veri), 1 To Worksheets.Count + 2)
        For i = 1 To UBound(Veri)
            Liste(i, 1) = Veri(i, 1)
            Liste(i, 2) = Veri(i, 2)
            For k = 3 To 7
                If Veri(i, k) = "x" Then
                    Liste(i, Kolon) = k - 2
                    Exit For
                End If
            Next k
        Next i
        Cells(1, Kolon) = Worksheets(x).Name
        son = Range("A" & Rows.Count).End(3).Row
        Range("A" & son).Offset(1, 0).Resize(UBound(Veri), Worksheets.Count + 2) = Liste
Devam:
    Next x
    Erase Liste: Erase Veri
End Sub

Teşekkür ederim. Şehir dışında olduğum için geç teşekkür edebildim. Eve döner dönmez deneyip sizi bilgilendireceğim.

 

[hadromer]

Merhaba, Aşağıdkai kodu bir module içine ekleyip, rapor sayfasında makroyu çalıştırabilirsiniz.

Sub TekTabloYap()
    Dim Veri, Liste()
    Dim x As Integer, i As Integer, k As Byte, son As Integer
    Cells.Clear
    Range("A1") = "Takson"
    Range("B1") = "Teşhis"
    Kolon = 2
    For x = 1 To Worksheets.Count
        son = Worksheets(x).Range("A" & Rows.Count).End(3).Row
        If Worksheets(x).Range("C1") <> "Bolluk (Ki)" Or son < 4 Then GoTo Devam
        Kolon = Kolon + 1
        Veri = Worksheets(x).Range("A4:G" & son).Value
        ReDim Liste(1 To UBound(Veri), 1 To Worksheets.Count + 2)
        For i = 1 To UBound(Veri)
            Liste(i, 1) = Veri(i, 1)
            Liste(i, 2) = Veri(i, 2)
            For k = 3 To 7
                If Veri(i, k) = "x" Then
                    Liste(i, Kolon) = k - 2
                    Exit For
                End If
            Next k
        Next i
        Cells(1, Kolon) = Worksheets(x).Name
        son = Range("A" & Rows.Count).End(3).Row
        Range("A" & son).Offset(1, 0).Resize(UBound(Veri), Worksheets.Count + 2) = Liste
Devam:
    Next x
    Erase Liste: Erase Veri
End Sub

Kodu şimdi denedim. Tam istediğim gibi çalışıyor ellerinize sağlık. Bir ricam daha var eğer bakabilirseniz çok memnun kalırım.
B sütununda teşhis kısmındaki verileri alırken yinelenen değer varsa tek değeri alsın istiyorum. Böyle bir güncelleme yapabilir misiniz ? Örneğin B3 te juncus diye bir veri var. bu veri diğer sayfalarda da var ise altına yeniden juncus yazıp karşısına değeri yazmak yerine mevcut juncus verisinin karşısına ilgili sayfadan (s1, s5 gibi) veriyi almasını istiyorum.

 

[ÖmerFaruk]

Takson da mı Teşihis de mi aynı olanlara bakacağız?
Soruda Teşhis diyorsunuz ama bana Taksondakiler gibi geliyor.

 

[hadromer]

Takson da mı Teşihis de mi aynı olanlara bakacağız?
Soruda Teşhis diyorsunuz ama bana Taksondakiler gibi geliyor.

ilk mesajımdaki yapmak istediklerimi #4 numaralı mesajda yazdığınız kodlar çok iyi karşıladı. Ancak çalışacağım dosya içeriği değiştiği için tekrar eden verilerin sayısı arttı. Bu yüzden #6 numaralı mesajdaki gibi bir değişiklik yapmam gerekiyor. Teşhis kısmında aynı olan veriyi almasın, ilgili verinin yanındaki hücrelere veriye ait değeri yazsın. Eğer yardımcı olursanız çok memnun olurum. Teşekkür ederim

 

[ÖmerFaruk]

Bir önceki mesajınızda yazdığınızı tekrar etmişiniz.
Ancak listeye bakınca, B sütununda bir sürü boş satırınız var. Aynı olanları tekrarlatmayacaksam bir sürü satır ediyor. Ayrıcı Juncus A sütununda da var.
Şimdi dediğinizi yapmak belki çok zor değil.
Ancak ilk çözümden sonda 12 saatte değişen dosya içeriğinizin şimdi tekrar değişesinden korkuyorum, sorunuzu tek seferde tüm detaylarıyla sormanızın bizi de yormayacağını hatırlatmaya çalışıyorum.

 

[hadromer]

Bir önceki mesajınızda yazdığınızı tekrar etmişiniz.
Ancak listeye bakınca, B sütununda bir sürü boş satırınız var. Aynı olanları tekrarlatmayacaksam bir sürü satır ediyor. Ayrıcı Juncus A sütununda da var.
Şimdi dediğinizi yapmak belki çok zor değil.
Ancak ilk çözümden sonda 12 saatte değişen dosya içeriğinizin şimdi tekrar değişesinden korkuyorum, sorunuzu tek seferde tüm detaylarıyla sormanızın bizi de yormayacağını hatırlatmaya çalışıyorum.

Ömer Faruk Bey,
ilgilendiğiniz için teşekkür ederim. Yazdığınız kod benim için yeterli bunun için minnettarım. Uzun zamandır bu forumdan faydalanıyorum. Sayısız yardım aldım. Değerli forum üyeleri sabırla bana yardımcı oldu. Ancak ilk defa yorgunlukla alakalı bir "hatırlatma" alıyorum. İkinci isteğim sadece bir "rica" idi. ".....bir ricam daha var eğer bakabilirseniz...." diye bir cümle kurmuştum. Sizi yorduğum için kusura bakmayın. Hepimiz biliyoruz ki burada gönüllülük esası var. Konu uzatmak istemiyorum. iyi geceler dilerim.