• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Soru Ayrı sayfalardaki hücrelerden veri alma

hadromer

hadromer

Altın Üye
Katılım
23 Ekim 2015
Mesajlar
405
Excel Vers. ve Dili
LTSC Professional Plus 2021 64 Bit Türkçe
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
Zz5B5Jav_resim_2022-01-30_195211.png
 
Merhaba,

Dosyanızı farklı bir siteye yükleyebilir misiniz?
 
Merhaba, Aşağıdkai kodu bir module içine ekleyip, rapor sayfasında makroyu çalıştırabilirsiniz.
C++: 
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
 
ÖmerFaruk' Alıntı:
Merhaba, Aşağıdkai kodu bir module içine ekleyip, rapor sayfasında makroyu çalıştırabilirsiniz.
C++: 
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
Genişletmek için tıkla ...
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.
 
ÖmerFaruk' Alıntı:
Merhaba, Aşağıdkai kodu bir module içine ekleyip, rapor sayfasında makroyu çalıştırabilirsiniz.
C++: 
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
Genişletmek için tıkla ...
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.
 
Takson da mı Teşihis de mi aynı olanlara bakacağız?
Soruda Teşhis diyorsunuz ama bana Taksondakiler gibi geliyor.
 
ÖmerFaruk' Alıntı:
Takson da mı Teşihis de mi aynı olanlara bakacağız?
Soruda Teşhis diyorsunuz ama bana Taksondakiler gibi geliyor.
Genişletmek için tıkla ...
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 :)
 
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.
 
ÖmerFaruk' Alıntı:
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.
Genişletmek için tıkla ...
Ö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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst