Farklı sayfalardaki aynı hücreleri listeleme

[SMSKMHMMT]

Herkese kolay gelsin;
200 sayfalık bir excel dosyam var, 200 sayfanın a1 hücresinde yazanları sabit bir sayfanın b sutununda listelemek ve bunu dinamik hale getirmek mümkün müdür? yani her yeni sayfa eklendiğinde listeye eklenmesi gerekir.
Şimdiden herkese teşekkür ederim.

 

[zozotr]

Bu kodu denermisiniz?
Hepsi isimli birsayfa oluşturun. Bir buton yada şekil ekleyip. Makro kodunu ekleyin.
Bu kod A sütununda Diğer sayfalardaki a1 hücresini ve B sütununda hangi sayfadan geldiğini yazar.

Sub a1hucreKopyalama()
    Dim ws As Worksheet
    Dim wsHepsi As Worksheet
    Dim LastRow As Long
    Dim i As Integer
   
 
    Set wsHepsi = ThisWorkbook.Sheets("Hepsi")
   
 
    wsHepsi.Range("A2:B" & wsHepsi.Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
   

    For Each ws In ThisWorkbook.Worksheets
     
        If ws.Name <> "Hepsi" Then
       
            LastRow = wsHepsi.Cells(Rows.Count, 1).End(xlUp).Row + 1
            wsHepsi.Cells(LastRow, 1).Value = ws.Range("A1").Value
            wsHepsi.Cells(LastRow, 2).Value = ws.Name
        End If
    Next ws
End Sub

 

[SMSKMHMMT]

Öncelikle teşekkür ederim kod çalışıyor ama hem a1 de yazanları hem de sayfa isimlerini yan yana iki sütunda yazdırıyor. sadece tüm sayfaların a1 hücresinde yazanı listelerse sevinirim, kod ile biraz uğraştım ama yapamadım.

 

[zozotr]

Sub a1HucreKopyalama()
    Dim ws As Worksheet
    Dim wsHepsi As Worksheet
    Dim LastRow As Long
    
    Set wsHepsi = ThisWorkbook.Sheets("Hepsi")
    
    wsHepsi.Range("A2:A" & wsHepsi.Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Hepsi" Then
            LastRow = wsHepsi.Cells(Rows.Count, 1).End(xlUp).Row + 1
            wsHepsi.Cells(LastRow, 1).Value = ws.Range("A1").Value
        End If
    Next ws
End Sub

bu şekilde sadece a1 hücre içeriklerini Hepsi Sayfası a2 den başlayarak listeleyebilirsiniz.

 

[SMSKMHMMT]

zozotr çok teşekkür ederim kod çok temiz çalıştı fakat bir sorum olacak öğrenmek adına başka sütuna yazdırmak istediğimde
wsHepsi.Range("A2:A" & wsHepsi.Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
kısmındaki "A2:A" kısmını mı değiştirmeliyim örneğin "c1:c" gibi.
Tekrar çok teşekkür ederim.

 

[zozotr]

Farklı sütuna yazdırmak için A2:A yı değiştirmeniz gerekiyor. Yukarıdaki kod dan örnek verecek olursak
A2:A değiğimiz kısım sayfanın ilk sütunu ve buna karşılık 1 ibaresi gelir.
örnek olarak c2:c ye yazdırmak istiyoruz. O zaman kodda birkaç değişiklik yapılması gerekir. Ben aşağıya ekleyeyim. siz kendinize göre uyarlayın.
Farklı sütun için renkli olan yerleri değiştirmeniz gerekiyor.
A sütunu 1
B sütunu 2
C sütunu 3 ve böyle devam ediyor.

Sub a1HucreKopyalama()
Dim ws As Worksheet
Dim wsHepsi As Worksheet
Dim LastRow As Long

Set wsHepsi = ThisWorkbook.Sheets("Hepsi")

wsHepsi.Range("C2:C" & wsHepsi.Cells(Rows.Count, 3).End(xlUp).Row).ClearContents

For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Hepsi" Then
LastRow = wsHepsi.Cells(Rows.Count, 3).End(xlUp).Row + 1
wsHepsi.Cells(LastRow, 3).Value = ws.Range("A1").Value
End If
Next ws
End Sub

 

[SMSKMHMMT]

Anladım çok faydalı oldu çok teşekkürler üstadım. İyi çalışmalar dilerim.

 

[SMSKMHMMT]

Tekrardan rahatsız ediyorum ama vermiş olduğunuz kod aktarma yaptığı sütunun en üst satırını siliyor yani başlık yazdığım satırı siliyor nasıl düzeltmem gerekir. Teşekkürler

 

[Korhan Ayhan]

Alanı temizleyen satırı böyle değiştirip deneyiniz.

wsHepsi.Range("C2:C" & Rows.Count).ClearContents

 

[SMSKMHMMT]

teşekkürler üstadım çalıştı.

 

[SMSKMHMMT]

Konuyu geliştirmek adına bir sorum daha olacak belki başkalarına da faydası olur. Yukarıdaki makro ile bir çok sayfada bulunan formların bir hücresinde yazan adı soyadı gibi bilgileri listeleyebildim, bu aslında =sayfa1!a5 yapmakla aynı durumun otomatik olmasıydı. Şuan yapmak istediğim ise yatayara formülünün otomatik olmasını sağlayarak ilk sayfada bulunan listedeki hücreleri kullanarak formdaki diğer verileri otomatik olarak karşılığına getirmek.
Örnek dosya linki bıraktım. Şimdiden teşekkür ederim.

https://dosya.co/9qybbgn9qfle/Yeni_Microsoft_Excel_Çalışma_Sayfası_(2).xlsx.html

 

[Korhan Ayhan]

Ekteki uygulamayı belki kullanmak istersiniz..