Verileri Tek Sayfada (SATIR BOŞLUKSUZ) toplamak

[49610]

Merhaba arkadaşlar,

Birden çok sayafadan veri toplayıp bir sayfaya otomatik olarak yazdırmak istiyorum.

Satıcılarımızın satışlarını toplu olarak tek bir sayfada görebilmek için, her satıcı için excelde bir sayfa açtım, onların satışları kendi sayfalarına dinamik bir şekilde geliyor. Ben bir başka sayfada da topluca görmek istiyorum ve verileri toplamayı başaramadım. Aralarda boş satır kalmasını önleyemiyorum. Dosyam ekte. Dosyada gerekli açıklama var. Yardımcı olabilecek arkadaşlara şimdiden teşekkürler.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu kullanabilirsiniz.

Sub AKTAR()
    Dim S1 As Worksheet, Sayfa As Worksheet, Satır As Long
 
    Application.ScreenUpdating = False
    Set S1 = Sheets("AKT_DURUMU")
 
    S1.Select
    Range("C2:M" & Rows.Count).ClearContents
 
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> S1.Name Then
            Satır = Cells(Rows.Count, 3).End(3).Row + 1
            Sayfa.Range("C2:M" & Sayfa.Cells(Rows.Count, 3).End(3).Row).Copy Cells(Satır, 3)
        End If
    Next
 
    Set S1 = Nothing
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[49610]

Üstadım, çok teşekkür ederim, elinize sağlık. Tam istediğim gibi.

Bir şey daha rica etsem;

verilerin otomatik olarak veri girildiğinde aktarılmasını nasıl sağlayabilirim.

Şimdiden teşekkürler.

 

[Korhan Ayhan]

Merhaba,

Dosyanızın "BuÇalışmaKitabı" bölümüne aşağıdaki kodu uygulayıp deneyin.

Verilerin ana sayfaya aktarılması için ilgili satırdaki C-M sütunları arasındaki tüm hücrelerin dolu olması gerekmektedir.

Mükerrerlik kontrolü "E" sütununa göre yapılmıştır.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim S1 As Worksheet, Satır As Long, BUL As Range
 
    On Error GoTo 10
    Set S1 = Sheets("AKT_DURUMU")
    
    If Intersect(Target, Range("B2:M" & Rows.Count)) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    If WorksheetFunction.CountA(Range("C" & Target.Row & ":M" & Target.Row)) = 11 Then
        If WorksheetFunction.CountIf(S1.Range("E:E"), Cells(Target.Row, 5)) > 0 Then
            If MsgBox("Bu veri daha önce aktarıldı. Güncellenmesini istiyor musunuz?", vbExclamation + vbYesNo) = vbNo Then GoTo 10
            Set BUL = S1.Range("E:E").Find(Cells(Target.Row, 5), , , xlWhole)
            Range("C" & Target.Row & ":M" & Target.Row).Copy S1.Range("C" & BUL.Row)
        Else
            Satır = S1.Cells(Rows.Count, 3).End(3).Row + 1
            Range("C" & Target.Row & ":M" & Target.Row).Copy S1.Range("C" & Satır)
        End If
    End If
    
10
    Set BUL = Nothing
    Set S1 = Nothing
    Application.EnableEvents = True
End Sub

 

[guzzia]

Koray hoca iyi geceler..
Konu başlığından sevinip benim soruma benzediğini zanettim ama dosyayı açtığımda çok farklı olduğunu gördüm. Benimki sanki daha basit gibi ama tabi cevabı belki zorda olabilir. Siteyi 6 aydır takip ediyorum, bayağı aramalarda yaptırdım ama bulamayışım beni rahatsız etmeye başladı. Bunu çok merak ediyorum ve işimede yarayacak.
Çok yalın anlatımıyla; mesela 1+1=2 formülünde hücreye her değeri girip enter'e bastığımda, sonucu yani 2 değerini, yanındaki veya başkabir sütunda anlık olarak, alt alta dizdirmek mümkünmüdür. Bunun için bir makroya ihtiyaç varmıdır yoksa basit bir işlevle halledilebilirmi. Yanıtlarsanız çok sevineceğim, şimdiden çok teşekkürler.

 

[guzzia]

Koray bey görebildinizmi bilmiyorum ama, yukarıdaki soruma bir excel dosyasıda ilave ettim, belki daha iyi anlaşılır. Anlatım şekli biraz uzun olduğu için site içi aramalarımda birtürlü yakalayamıyorum cevabı. Dosyayı açtığınızda durumun farklı olduğunu göreceksiniz. Size özel mesaj atıp rahatsız etmek istemedim sabırla bu mesajı görmenizi bekliyorum.
İlginize teşekkürler.