• DİKKAT

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

Fatura listesi özet tablosu hakkında

K

keskinbicak

Katılım
28 Kasım 2011
Mesajlar
18
Excel Vers. ve Dili
2007 türkçe
Merhaba sayın üstadlar
Ekli dosyayı bir arkadaş yapmış. ben bunu kendime göre uyarladım. aylara göre ayrılmış sayfalardaki bilgileri "genel" sayfasında toplu liste olarak çıkarabiliyorum. ama benim yapmak istediğim "özet" sayfasına fatura listelerinde geçen isimlerinaylara göre fatura tutarlarını almak.

Yani Aylar Sayfasında Listelenen İsimleri özet sayfa Alanına Getirecek Ve O Aya Ait Fatura Tutarını Ait Olduğu Sütuna Yazacak. Fatura Listesine Yeni Bir İsim Girildiğinde Otomatik Olarak Bu Sayfayada O İsmi Aktaracak.
Tüm Aylardaki Öğrencilerin İsimlerini Alfabetik Olarak Listeleyip Aylara Göre Fatura Tutarlarını Almamız Mümkünmü


detaylı açıklamayı ekli dosyadada yaptım.
birde dosya çok hantallaştı anlamadım neden oldu :)
 
Son düzenleme:
Merhaba,
Alternatif olarak bu kodu da kullanabilirsiniz.

Sub Aktar()
Range("A2:J10000") = ""
For i = 3 To 14
son = Range("C10000").End(3).Row + 1
son1 = Sheets(i).Range("C1000").End(3).Row
Range("A" & son & ":J" & son + son1 - 3) = Sheets(i).Range("A3:J" & son1).Value
Next
End Sub
Genişletmek için tıkla ...
 
bedri41' Alıntı:
Ekteki dosyanızı inceleyiniz
Kolay Gelsin
Genişletmek için tıkla ...

Hocam çok teşekkür ederim. Zahmet verdim size

Ama son bir isteğim var.
Yaptığınız tablo rakamları gayet güzel getiriyor.
Ama dikkat ederseniz bazılarında ücretsiz yazıyor.
Yani Rakam harici yazılarıda getirmemiz mümkünmü?
 
Merhaba,
Aşağıdaki kodu deneyiniz.

Sub Aktar()
Application.ScreenUpdating = False
Range("A3:Q10000") = ""
On Error Resume Next
For i = 3 To 14
son = Range("B10000").End(3).Row + 1
son1 = Sheets(i).Range("C1000").End(3).Row
Range("B" & son & ":D" & son + son1 - 3) = Sheets(i).Range("C3:E" & son1).Value
Next
son = Range("B10000").End(3).Row
For i = son To 3 Step -1
If WorksheetFunction.CountIf(Range("B3:B" & i), Cells(i, 2)) > 1 Then Rows(i).Delete
Next
For i = 3 To 14
son = Range("B10000").End(3).Row
For j = 3 To son
kac = WorksheetFunction.Match(Cells(j, 2), Sheets(i).Range("C1:C1000"), 0)
Cells(j, i + 2) = Sheets(i).Cells(kac, 10).Value
Next j
Next i

son = Range("B10000").End(3).Row
Range("Q3:Q" & son) = "=SUM(E3:P3)"
Range("Q3:Q" & son) = Range("Q3:Q" & son).Value
Range("B3:Q" & son).Borders.LineStyle = 1
End Sub
Genişletmek için tıkla ...
 
maalesef hocam şekli şemali değişti tablonun. 2 sütun sağa kaydı. yazıları getirdi ama pek doğru yerlere değil.
bedri41 hocamın yaptığı çok güzel çalışıyor lakin tek sorun fatura tutarı kısmında rakam haricini getirmiyor
 
Sub Aktar()
Application.ScreenUpdating = False
Range("A3:Q10000") = ""
On Error Resume Next
For i = 3 To 14
son = Range("B10000").End(3).Row + 1
son1 = Sheets(i).Range("C1000").End(3).Row
Range("B" & son & ":D" & son + son1 - 3) = Sheets(i).Range("C3:E" & son1).Value
Next
son = Range("B10000").End(3).Row
For i = son To 3 Step -1
If WorksheetFunction.CountIf(Range("B3:B" & i), Cells(i, 2)) > 1 Then Rows(i).Delete
Next
For i = 3 To 14
son = Range("B10000").End(3).Row
For j = 3 To son
If WorksheetFunction.CountIf(Sheets(i).Range("C1:C1000"), Cells(j, 2)) = 0 Then GoTo 10
kac = WorksheetFunction.Match(Cells(j, 2), Sheets(i).Range("C1:C1000"), 0)
Cells(j, i + 2) = Sheets(i).Cells(kac, 10).Value
10
Next j
Next i

son = Range("B10000").End(3).Row
Range("Q3:Q" & son) = "=SUM(E3:P3)"
Range("Q3:Q" & son) = Range("Q3:Q" & son).Value
Range("B3:Q" & son).Borders.LineStyle = 1
End Sub
Genişletmek için tıkla ...


Dosyayı inceleyiniz. İki sütun kayması A sütununu boş bıraktım, B sütunu TC kimlik numaraları ekledim. Eğer Adlar A sütununa dayandırılmasının bi önemi varsa ona göre değiştirelim.
 

Ekli dosyalar

Son düzenleme:
Sub Aktar()
Application.ScreenUpdating = False
Range("A3:Q10000") = ""
Columns(1).Insert
Range("A2") = "TC"
On Error Resume Next
For i = 3 To 14
son = Range("A10000").End(3).Row + 1
son1 = Sheets(i).Range("C1000").End(3).Row
Range("A" & son & ":C" & son + son1 - 3) = Sheets(i).Range("C3:E" & son1).Value
Next
son = Range("A10000").End(3).Row
For i = son To 3 Step -1
If WorksheetFunction.CountIf(Range("A3:A" & i), Cells(i, 1)) > 1 Then Rows(i).Delete
Next
For i = 3 To 14
son = Range("A10000").End(3).Row
For j = 3 To son
If WorksheetFunction.CountIf(Sheets(i).Range("C1:C1000"), Cells(j, 1)) = 0 Then GoTo 10
kac = WorksheetFunction.Match(Cells(j, 1), Sheets(i).Range("C1:C1000"), 0)
Cells(j, i + 1) = Sheets(i).Cells(kac, 10).Value
10
Next j
Next i

son = Range("A10000").End(3).Row
Range("P3:P" & son) = "=SUM(D3:O3)"
Range("P3:P" & son) = Range("P3:P" & son).Value
Range("A3:P" & son).Borders.LineStyle = 1
Columns(1).Delete
End Sub
Genişletmek için tıkla ...

Kodu A sütununa dayalı şekilde yapıyor.
 

Ekli dosyalar

tamam hocam şimdi oldu
isimlerin a sütununa daynadırmanın bi önemi yok. TC li liste kalması daha iyi
Sadece ocak,şubat,mart.....aralık tüm aylarda yapmış olduğum değişiklik otomatik olarak özet sayfasındada değişirse benim için yeterli olacak. (bedri41 hocamın yaptığında otomatik değişiklik oluyordu)
Birde dosyanın yavaş çalışması normalmi?
 
Bu dosyayı deniyorsanız ben de 1 sn bile tutmuyor. 11 nolu mesadaki kodun en altına
Range("B3:Q" & son).Sort Key1:=Range("C3"), ORDER1:=xlAscending, Key2:=Range("D3"), ORDER2:=xlAscending
Genişletmek için tıkla ...
eklerseniz alfabetik olarak sıralar.
 
Veri sayısı arttıkça döngü sayısıda artacağından yavaşlama olabilir. Dosyanızda formül varsa onlar da yavaşlatabilir.
 
Tamam hocam çok teşekkür ederim.
size zahmet olmazsa son ricam bu ocak,şubat,mart.....aralık tüm aylarda yapmış olduğum değişiklik otomatik olarak özet sayfasındada değiştirme durumu kolaysa onuda yapsak süper olacak. (bedri41 hocamın yaptığında otomatik değişiklik oluyordu)
 
keskinbicak' Alıntı:
Tamam hocam çok teşekkür ederim.
size zahmet olmazsa son ricam bu ocak,şubat,mart.....aralık tüm aylarda yapmış olduğum değişiklik otomatik olarak özet sayfasındada değiştirme durumu kolaysa onuda yapsak süper olacak. (bedri41 hocamın yaptığında otomatik değişiklik oluyordu)
Genişletmek için tıkla ...

Benim yaptığım amatör çözüm dosyasında hücrelere toplam alacak formül yazdırılıyordu dolayısyla rakamlar değiştikçe de toplamlar değişiyordu ancak onda da rakam olmayan değerler (ÜCRETSİZ gibi) getirilemiyor.

Muhammet hocamızın kodları zaten bu durumuda halletmiş. Sizin tek yapmanız gereken özet sayfasına girdiğinizde butona basmak.

Kolay Gelsin
 
Sub Aktar1()
Range("K1") = ""
Range("J1") = Now
Dim i As Byte
Dim j, son, son1 As Integer
Application.ScreenUpdating = False
Range("B3:Q10000").Borders.LineStyle = 0
Range("A3:Q10000") = ""
On Error Resume Next
For i = 3 To 14
son = Range("B10000").End(3).Row + 1
son1 = Sheets(i).Range("C1000").End(3).Row
Range("B" & son & ":D" & son + son1 - 3) = Sheets(i).Range("C3:E" & son1).Value
Next

son = Range("B10000").End(3).Row
ActiveSheet.Range("B3:D" & son).RemoveDuplicates Columns:=Array(1, 3)

For i = 3 To 14
son = Range("B10000").End(3).Row
For j = 3 To son
If WorksheetFunction.CountIf(Sheets(i).Range("C1:C1000"), Cells(j, 2)) = 0 Then GoTo 10
kac = WorksheetFunction.Match(Cells(j, 2), Sheets(i).Range("C1:C1000"), 0)
Cells(j, i + 2) = Sheets(i).Cells(kac, 10).Value
10
Next j
Next i

son = Range("B10000").End(3).Row
Range("Q3:Q" & son) = "=SUM(E3:P3)"
Range("Q3:Q" & son) = Range("Q3:Q" & son).Value
Range("B3:Q" & son).Borders.LineStyle = 1
Range("B3:Q" & son).Sort Key1:=Range("C3"), ORDER1:=xlAscending, Key2:=Range("D3"), ORDER2:=xlAscending
Range("K1") = Now

End Sub
Genişletmek için tıkla ...

Bu da başka bir yöntem. Hız olarak pek fark yok ama. Bu kod 4000 veriyi 6 saniyede, 11 nolu mesajdaki kodlar ise 7 saniyede işlemi gerçekleştirdi. Ben 2010 sürümünü kullanıyorum. Önceki versiyonlardan yada sizin bilgisayar donanımından kaynaklanıyor olabilir.
 
Haklısınız hocam. ben 2007 kullanıyorum ayrıca gerçek verileri girince biraz yavaşlama oluyor ama sorun değil.
çok teşekkür ediyorum. Allah razı olsun
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst