• DİKKAT

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

Birçok Sayfadan Veri Getirmek!!!!

  • Konbuyu başlatan Konbuyu başlatan sinan05
  • Başlangıç tarihi Başlangıç tarihi
S

sinan05

Katılım
16 Kasım 2017
Mesajlar
255
Excel Vers. ve Dili
office professional plus 2021
iyi Günler, herkese hayırlı yıllar dilerim. Aşağıya ekledğim kodlarla çalışma kitabımdaki "VERİLER" sayfasından "ANA SAYFA" ya verileri kopyalıyorum. Fakat kitabıma onlarca sayfa ekledim ve sürekli sayfalar artıyor. İstediğim çalışma kitabımdaki tüm sayfalardaki verileri "ANA SAYFA" sayfasına verilerin sadece değerlerini kopyalamak. Eklediğim makro buna uyarlanırmı bilemiyorum.Yardımlarınız için teşekkür ederim.
Sub KAYİT2()
Application.ScreenUpdating = False
Dim S1 As Worksheet, S2 As Worksheet, Defterler(), Son As Long, Satır As Long
Set S1 = Sheets("VERİLER")
Defterler = Array("ANA SAYFA")
Satır = 4
For Each defter In Defterler
Set S2 = Sheets(defter)
Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
Son1 = Sheets("ANA SAYFA").[a65536].End(3).Row + 1
For x = 4 To Son
S2.Range("A" & x & ":U" & x).Copy
Sheets("ANA SAYFA").Cells(Son1, 1).PasteSpecial xlPasteValues
Son1 = Son1 + 1
Next x
Next
Range("B4").Select
S2.Range("A4:U" & S2.Rows.Count).ClearContents
Application.ScreenUpdating = True
End Sub
 
Merhaba.
Örnek dosya hazırlayın. Sayfalardan veriler Ana sayfaya alındığında nasıl olmasını istiyorsanız uygulayarak gösterin.
Örnek dosyanızı dosya.tc gibi bir siteye ekleyebilirsiniz.
 
Muzaffer Ali' Alıntı:
Merhaba.
Örnek dosya hazırlayın. Sayfalardan veriler Ana sayfaya alındığında nasıl olmasını istiyorsanız uygulayarak gösterin.
Örnek dosyanızı dosya.tc gibi bir siteye ekleyebilirsiniz.
Genişletmek için tıkla ...

Merhaba Muzaffer hocam. Örnek dosyayı ekledim linki : https://s6.dosya.tc/server6/c5pn9n/ornek_dosya.xlsm.html

Hocam burdaki amacım diğer sayfalardaki 2. satırda bulunan a2:ı2: arası verileri ana sayfa ya yalnızca değerleri şeklinde kopyalamak.
 
Hiç örnek yapmamışsınız.
En azından bir tane örnek yapın.

Örneğin "Veriler" sayfasına gerçeğe yakın değerler yazın.
Veriler sayfasından "Ana Sayfa" ya elinizle verileri aktarın.

Ben de bu örneğe göre kod yazayım.
 
hocam her sayfanın 2 satırı dolu benim istediğim alan burası zaten. ana sayfa daki listele butonu veriler sayfasının 2.satırdaki a ile ı aralığını getiriyor. benim istediğim ilaveten tüm sayfalardaki aynı aralığın verilerinide getirsin. başka girilmesi gereken veri yok ki. listele butonu veriler sayfasındakini getiriyor bütün sayfalarınkini getirmesi lazım.
Muzaffer Ali' Alıntı:
Hiç örnek yapmamışsınız.
En azından bir tane örnek yapın.

Örneğin "Veriler" sayfasına gerçeğe yakın değerler yazın.
Veriler sayfasından "Ana Sayfa" ya elinizle verileri aktarın.

Ben de bu örneğe göre kod yazayım.
Genişletmek için tıkla ...
 
Aşağıdaki kodu deneyin.
Kod: 
Sub Test()
    Application.ScreenUpdating = False
    Dim syfAna As Worksheet, syf As Worksheet
    Dim SayAna As Long, Saysyf As Long
    Set syfAna = Sheets("ANA SAYFA")
    For Each syf In ThisWorkbook.Worksheets
        If Not syf.Name = "ANA SAYFA" Then
            SayAna = syfAna.Cells(Rows.Count, "A").End(xlUp).Row + 1
            Saysyf = syf.Cells(Rows.Count, "A").End(xlUp).Row
            syf.Range("A2:I2").Copy
            syfAna.Cells(SayAna, "A").PasteSpecial xlPasteValues
        End If
    Next
    Application.ScreenUpdating = True
End Sub
 
Muzaffer Ali' Alıntı:
Aşağıdaki kodu deneyin.
Kod: 
Sub Test()
    Application.ScreenUpdating = False
    Dim syfAna As Worksheet, syf As Worksheet
    Dim SayAna As Long, Saysyf As Long
    Set syfAna = Sheets("ANA SAYFA")
    For Each syf In ThisWorkbook.Worksheets
        If Not syf.Name = "ANA SAYFA" Then
            SayAna = syfAna.Cells(Rows.Count, "A").End(xlUp).Row + 1
            Saysyf = syf.Cells(Rows.Count, "A").End(xlUp).Row
            syf.Range("A2:I2").Copy
            syfAna.Cells(SayAna, "A").PasteSpecial xlPasteValues
        End If
    Next
    Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...
Hocam elinize sağlık çok teşekkür ederim tam istediğim gibi oldu harika.
2 isteğimi rica edebilirmiyim.1.si Hocam kopyalamasını istemediğim" bitenler " sayfası var bu sayfayı kopylamasa
2. bu sayfalar çağaldıkça ağırlaşıyor bende bitenleri arşivliyorum. makro kaydederek veya kodları değiştirerek uğraştım araştırdım yapamadım.eğer her sayfanın h6 hücresinde "bitti" yazıyorsa o sayfayı masaüstünde bulunan yedekler klosöründeki data kitabına kopyalasa sonrada o sayfayı benim kitabımdan silse çok güzel olur. bunlarıda yaparsak işlerimi yapabilcem çok makbule geçe MUZAFFER Hocamr.
 
Data dosyası kapalıysa açıp sayfa taşıyıp kaydedip kapatır. Data dosyası açıksa sadece sayfayı taşır.
Kod: 
Option Explicit

Sub Test()
    Dim syfAna As Worksheet, syf As Worksheet
    Dim SayAna As Long
    Application.ScreenUpdating = False
    Set syfAna = ThisWorkbook.Sheets("ANA SAYFA")
    For Each syf In ThisWorkbook.Worksheets
        If Not syf.Name = "ANA SAYFA" And Not syf.Name = "Bitenler" Then 'Başka kopyalanmasını istemediğiniz sayfa varsa bu satırdaki gibi ekleyebilirsiniz.
            SayAna = syfAna.Cells(Rows.Count, "A").End(xlUp).Row + 1
            syf.Range("A2:I2").Copy
            syfAna.Cells(SayAna, "A").PasteSpecial xlPasteValues
        End If
        If syf.Range("H6") = "Bitti" Then SayfaTasi syf
    Next
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı."
End Sub

Sub SayfaTasi(syf As Worksheet)
    Dim wb As Workbook, wbData As Workbook
    Dim DataDosyaAdi As String
    Dim DataDosyaYolu As String
    
    DataDosyaAdi = "Data.xlsx"
    DataDosyaYolu = Environ("UserProfile") & "\Desktop\Yedekler\"
    
    For Each wb In Workbooks
        If wb.Name = DataDosyaAdi Then
            Set wbData = wb
            Exit For
        End If
    Next
    If wbData Is Nothing Then
        Workbooks.Open DataDosyaYolu & DataDosyaAdi
        syf.Move After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
        ActiveWorkbook.Close True
    Else
        syf.Move After:=wbData.Sheets(wbData.Sheets.Count)
        ThisWorkbook.Activate
    End If
End Sub
 
Muzaffer Ali' Alıntı:
Data dosyası kapalıysa açıp sayfa taşıyıp kaydedip kapatır. Data dosyası açıksa sadece sayfayı taşır.
Kod: 
Option Explicit

Sub Test()
    Dim syfAna As Worksheet, syf As Worksheet
    Dim SayAna As Long
    Application.ScreenUpdating = False
    Set syfAna = ThisWorkbook.Sheets("ANA SAYFA")
    For Each syf In ThisWorkbook.Worksheets
        If Not syf.Name = "ANA SAYFA" And Not syf.Name = "Bitenler" Then 'Başka kopyalanmasını istemediğiniz sayfa varsa bu satırdaki gibi ekleyebilirsiniz.
            SayAna = syfAna.Cells(Rows.Count, "A").End(xlUp).Row + 1
            syf.Range("A2:I2").Copy
            syfAna.Cells(SayAna, "A").PasteSpecial xlPasteValues
        End If
        If syf.Range("H6") = "Bitti" Then SayfaTasi syf
    Next
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı."
End Sub

Sub SayfaTasi(syf As Worksheet)
    Dim wb As Workbook, wbData As Workbook
    Dim DataDosyaAdi As String
    Dim DataDosyaYolu As String
  
    DataDosyaAdi = "Data.xlsx"
    DataDosyaYolu = Environ("UserProfile") & "\Desktop\Yedekler\"
  
    For Each wb In Workbooks
        If wb.Name = DataDosyaAdi Then
            Set wbData = wb
            Exit For
        End If
    Next
    If wbData Is Nothing Then
        Workbooks.Open DataDosyaYolu & DataDosyaAdi
        syf.Move After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
        ActiveWorkbook.Close True
    Else
        syf.Move After:=wbData.Sheets(wbData.Sheets.Count)
        ThisWorkbook.Activate
    End If
End Sub
Genişletmek için tıkla ...
Muzaffer Hocam eksik olmayın çok güzel hazırlamışsınız çok sağolun. Fakat ben anlatamadım sanırım, bu "If syf.Range("H6") = "Bitti" Then SayfaTasi syf" kodu SayfaTası makrosu için istiyordum. Yani sayfaların H6 hücresinde BİTTİ yazıyorsa o sayfa taşınsın diye düşünmüştüm. sayfalardan ana sayfaya veri getirirken herhangi bir koşula gerek yok Hocam.
NOT: Muzaffer Hocam herhalde ben olayı yanlış anladım. Üsteki makro koşula göre SayfaTaşı makrosunu çalıştırıyor galiba.
 
Son düzenleme:
Muzaffer Hocam SayfaTaşı makrosunda bu kod "Workbooks.Open DataDosyaYolu & DataDosyaAdi" hata veriyor. dosya masa üstünde dosya adlarınıda kontrol ettim bir hata yok.
NOT: MUZAFFER Hocam çalışma Data dosyasının uzantısı farklıymış xlsm olarak değiştirdim çalıştı.Aynen süper çalışıyor ALLAH RAZI OLSUN vakit ayırdınız çok teşekkür ederim emeğinize.
 
Son düzenleme:
Allah hepimizden razı olsun inşallah.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst