• DİKKAT

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

Firma adına göre bilgileri raporlamak

E

Equque

Katılım
6 Ağustos 2013
Mesajlar
57
Excel Vers. ve Dili
2010
Ustalarım selamlar,

Excel dosyamda "Bilgiler" adında sekmem var ikici bir sekme açtım adı "Raporlama" istiyorum ki "Raporlama" sekmesinde firma ismini çağırdığımda "Bilgiler" sekmesindeki verileri tarih sırasına göre listeleme yapsın yardımcı olabilir misiniz

Program.xlsx dosyasını indir - download

Program.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
www.dosya.tc www.dosya.tc
 
Merhaba
Raporlama Sayfasının kod bölümüne yapıştırır mısınız?
Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Dim S1 As Worksheet, STR As Long Set S1 = Sheets("Bilgiler"): STR = S1.Range("B" & Rows.Count).End(xlUp).Row If Target.Column = 4 Then If Intersect(Target, Range("D1")) Is Nothing Then _ Application.EnableEvents = True: Exit Sub Range("A3:J" & Rows.Count).Clear S1.Range("A1:K" & STR).AutoFilter 4, Target If WorksheetFunction.Subtotal(3, S1.Range("B2:B" & STR)) > 0 Then S1.Range("B2:K" & STR).Copy Range("A3") End If S1.Range("A1:K" & STR).AutoFilter End If Application.EnableEvents = True End Sub
 
asi_kral' Alıntı:
Merhaba
Raporlama Sayfasının kod bölümüne yapıştırır mısınız?
Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Dim S1 As Worksheet, STR As Long Set S1 = Sheets("Bilgiler"): STR = S1.Range("B" & Rows.Count).End(xlUp).Row If Target.Column = 4 Then If Intersect(Target, Range("D1")) Is Nothing Then _ Application.EnableEvents = True: Exit Sub Range("A3:J" & Rows.Count).Clear S1.Range("A1:K" & STR).AutoFilter 4, Target If WorksheetFunction.Subtotal(3, S1.Range("B2:B" & STR)) > 0 Then S1.Range("B2:K" & STR).Copy Range("A3") End If S1.Range("A1:K" & STR).AutoFilter End If Application.EnableEvents = True End Sub
Genişletmek için tıkla ...
Çok teşekkür ederim istediğim olmuş elinize sağlık.

Peki biçim olarak standart gelmesi için nasıl yapmalıyız yani arka plandaki renk olmaması için ?
Tarih sıralamasına göre gelmesi için nasıl yapmalıyız ? eskiden yeniye veya en yeni kayıttan en eski kayda ?
 
Son düzenleme:
Equque' Alıntı:
Çok teşekkür ederim istediğim olmuş elinize sağlık.

Peki biçim olarak standart gelmesi için nasıl yapmalıyız yani arka plandaki renk olmaması için ?
Tarih sıralamasına göre gelmesi için nasıl yapmalıyız ? eskiden yeniye veya en yeni kayıttan en eski kayda ?
Genişletmek için tıkla ...

Kodu bununla değiştirip dener misiniz?
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim S1 As Worksheet, STR As Long
Set S1 = Sheets("Bilgiler"): STR = S1.Range("B" & Rows.Count).End(xlUp).Row
If Target.Column = 4 Then
If Intersect(Target, Range("D1")) Is Nothing Then _
Application.EnableEvents = True: Exit Sub
Range("A3:J" & Rows.Count).ClearContents
S1.Range("A1:K" & STR).AutoFilter 4, Target
If WorksheetFunction.Subtotal(3, S1.Range("B2:B" & STR)) > 0 Then
S1.Range("B2:K" & STR).Copy
Range("A3").PasteSpecial (xlPasteValues): Range("D1").Select
Range("A3:J" & Rows.Count).Sort Range("A3")
End If
S1.Range("A1:K" & STR).AutoFilter
End If
Application.EnableEvents = True
End Sub
 
Hocam çok teşekkür ederim herşey güzel oldu fakat şöyle birşey daha ekledik, "Kolisaj Çıkart" adında bir sekme oluşturduk "Bilgiler" sekmemde ise kolisaj numaraları olan satırlar var yapmak istediğimiz "Kolisaj Çıkart" sekmesine kolisaj no girdiğimizde "Bilgiler" sekmesinden kolisaj numaralarını alıp kopyalama yapsın (((bir önceki yardımcı olduğunuz konu ile aynı mantıkta o firma raporu idi bu ise kolisaj fakat makro üzerinde o kadar uğraştım ama yapamadım))) kopyalamış olduğu sütünlardan Lotu, Bürüt, Darası, Net Kg sütunların altına ise toplama işlemi yaptırmak istiyorum affınıza sığınarak çok fazla oldu farkındayım fakat yapabilirsek çok memnun olacağım

Program.xlsx dosyasını indir - download

Program.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
s6.dosya.tc s6.dosya.tc
 
Merhaba
Bu kodu dener misiniz?
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim S1 As Worksheet, STR As Long
Set S1 = Sheets("Bilgiler"): STR = S1.Range("B" & Rows.Count).End(xlUp).Row
If Target.Column = 4 Then
If Intersect(Target, Range("D1")) Is Nothing Then _
Application.EnableEvents = True: Exit Sub
Range("A3:H" & Rows.Count).ClearContents
S1.Range("A1:L" & STR).AutoFilter 3, Target
If WorksheetFunction.Subtotal(3, S1.Range("B2:B" & STR)) > 0 Then
S1.Range("B2:B" & STR).Copy: Range("A3").PasteSpecial (xlPasteValues)
S1.Range("D2:G" & STR).Copy: Range("B3").PasteSpecial (xlPasteValues)
S1.Range("I2:K" & STR).Copy: Range("F3").PasteSpecial (xlPasteValues)
Target.Select
Range("A3:H" & Rows.Count).Sort Range("A3")
End If
S1.Range("A1:L" & STR).AutoFilter
End If
STR = Range("A" & Rows.Count).End(xlUp).Row
Range("B" & STR + 3) = "Toplam"
Range("E" & STR + 3) = WorksheetFunction.Sum(Range("E3:E" & STR))
Range("F" & STR + 3) = WorksheetFunction.Sum(Range("F3:F" & STR))
Range("G" & STR + 3) = WorksheetFunction.Sum(Range("G3:G" & STR))
Range("H" & STR + 3) = WorksheetFunction.Sum(Range("H3:H" & STR))
Application.EnableEvents = True
End Sub
 
asi_kral' Alıntı:
Merhaba
Bu kodu dener misiniz?
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim S1 As Worksheet, STR As Long
Set S1 = Sheets("Bilgiler"): STR = S1.Range("B" & Rows.Count).End(xlUp).Row
If Target.Column = 4 Then
If Intersect(Target, Range("D1")) Is Nothing Then _
Application.EnableEvents = True: Exit Sub
Range("A3:H" & Rows.Count).ClearContents
S1.Range("A1:L" & STR).AutoFilter 3, Target
If WorksheetFunction.Subtotal(3, S1.Range("B2:B" & STR)) > 0 Then
S1.Range("B2:B" & STR).Copy: Range("A3").PasteSpecial (xlPasteValues)
S1.Range("D2:G" & STR).Copy: Range("B3").PasteSpecial (xlPasteValues)
S1.Range("I2:K" & STR).Copy: Range("F3").PasteSpecial (xlPasteValues)
Target.Select
Range("A3:H" & Rows.Count).Sort Range("A3")
End If
S1.Range("A1:L" & STR).AutoFilter
End If
STR = Range("A" & Rows.Count).End(xlUp).Row
Range("B" & STR + 3) = "Toplam"
Range("E" & STR + 3) = WorksheetFunction.Sum(Range("E3:E" & STR))
Range("F" & STR + 3) = WorksheetFunction.Sum(Range("F3:F" & STR))
Range("G" & STR + 3) = WorksheetFunction.Sum(Range("G3:G" & STR))
Range("H" & STR + 3) = WorksheetFunction.Sum(Range("H3:H" & STR))
Application.EnableEvents = True
End Sub
Genişletmek için tıkla ...
Çok teşekkür ederim yardımınız için çok faydalı oldu istediğimiz oldu minnettarım...
 
Hocam tekrar bilginize başvuruyorum "Kolisaj çıkart" sekmesinde Eğer hücre doluysa kenarlık eklesin makrosunu ekleyebilirmisiniz "Raporlama" sekmesinde de aynı biçimsizlik vardı ben onu Koşullu Biçimlendirme ile yaptım fakat "Kolisaj çıkart" sekmesinde çalışmadı sizden ricam sadece "Kolisaj çıkart" sekmesinde gelen verilere kenarlık eklemeniz,

Program.xlsm dosyasını indir - download

Program.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
s6.dosya.tc s6.dosya.tc
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst