Tarihlere Veri aktar

[Ahmet Sami]

Ardaşlar sizden istediğim yardım, KAYIT sayfamda kaydettiğim yüzlerce bilginin ayrı ayrı sayfalarda yer alan illere aylık tarih olarak aktarılması,
Örnek: KAYIT sayfasında yer alan ADANA iline gönderilmiş ay içerisindeki malzemelerin Malzeme adlarına göre il sayfalarına Malzemenin tutarı yerine gelir ve gider olarak yazılması ayrıca aynı ile aynı malzeme bir ay içerisinde birkaç defa daha gitmiş olabilir örnekte mevcuttur. Yeşil renk ile işaretlenmiştir.
Yardımlarınız için teşekkür ederim.

 

[Ömer]

Merhaba,

Kayıt sayfasının kod bölümüne kopyalayınız.

Private Sub Worksheet_Deactivate()
   
    Dim i As Long, S1 As Worksheet, c As Range, t As Date, s As Range
   
    Application.ScreenUpdating = False
   
    For Each S1 In ThisWorkbook.Worksheets
        If S1.Name <> "KAYIT" Then
            S1.Range("B4:BM" & Rows.Count).ClearContents
        End If
    Next
   
    For i = 2 To Cells(Rows.Count, "C").End(xlUp).Row
        Set S1 = Sheets(Cells(i, "C").Text)
        Set c = S1.[A:A].Find(Cells(i, "E"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            t = DateSerial(Year(Cells(i, "B")), Month(Cells(i, "B")), 1)
            Set s = S1.Rows(2).Find(t)
            If Not s Is Nothing Then
                S1.Cells(c.Row, s.Column) = S1.Cells(c.Row, s.Column) + Cells(i, "G")
                S1.Cells(c.Row, s.Column + 1) = S1.Cells(c.Row, s.Column + 1) + Cells(i, "H")
            End If
        End If
    Next i
   
    Application.ScreenUpdating = True
   
End Sub

 

[YUSUF44]

Aşağıdaki formülü İl sayfalarının B3 hücresine yapıştırıp aşağı doğru kopyalayınız:

=TOPLA.ÇARPIM((KAYIT!$C$2:$C$1300=$A$1)*(AY(KAYIT!$B$2:$B$1300)=AY(B$2))*(YIL(KAYIT!$B$2:$B$1300)=YIL(B$2))*(KAYIT!$E$2:$E$1300=$A4)*KAYIT!$G$2:$G$1300)

Aşağıdaki formülü il sayfalarının C3 hücresine yapıştırıp aşağı doğru kopyalayınız:

=TOPLA.ÇARPIM((KAYIT!$C$2:$C$1300=$A$1)*(AY(KAYIT!$B$2:$B$1300)=AY(B$2))*(YIL(KAYIT!$B$2:$B$1300)=YIL(B$2))*(KAYIT!$E$2:$E$1300=$A4)*KAYIT!$H$2:$H$1300)

Bu sütunları yandaki sütunlara kopyalayınız.

Yalnız bu formül exceli çok yorar. Verileriniz çoğaldıkça sonuç almanız zorlaşır hatta excel kilitlenebilir.

Böyle bir çözüm yerine bir ana sayfa bir de rapor sayfası oluşturup, rapor sayfasında istediğiniz kriterlere göre sonuç elde etmek daha doğru olur diye düşünüyorum.

 

[Ahmet Sami]

Sayın Ömer Bey ve Sayın Yusuf bey çok teşekkür ederim.
Ömer bey, Yusuf beyinde söylediği gibi bir KAYIT sayfası birde LİSTE sayfası yaptım. KAYIT sayfasına D1 hücresine ilin adını yazdığım zaman hangi il ise o şekilde aktarma yapsa kodu ona göre rica etsem düzenleyebilir misiniz.

 

[Ömer]

Adana yazdınız. Adana verilerini Liste sayfasını aktardı. Daha sonra Ankara yazdınız. Liste sayfasında nasıl bir işlem olacak?

 

[YUSUF44]

Son dosyanızı Ömer üstadın kodlarını da kullanarak düzenledim. LİSTE sayfasında A1 hücresine tıkladığınızda bir listbox açılacak ve ordan seçtiğiniz ilin verileri sayfada listelenecek. Ekli dosyayı inceleyiniz.

 

[Ahmet Sami]

Yusuf Bey ve Ömer Bey saygılarımla teşekkür ederim. Her ikisi de işimi fazlası ile gördü. Sadece Kod biraz daha sadeleştirilebilir mi şayet olmuyorsa böyle de işimi görür sağolun.

 

[YUSUF44]

Sadeleştirmekten kastınız nedir? Koddaki her satır istediğiniz sonucun elde edilmesi için gerekli olan işlemler yapıyor.

 

[Ahmet Sami]

Teşekkür ederim Yusuf bey sağolun

 

[Ahmet Sami]

Yusuf bey kusuruma bakmayın, İL adı ile çağırdığım zaman geliyor ancak MALZEME ADI bölümünü ile göre değil genele göre getiriyor. Mesela, ANKARA yı seçtiğim zaman sadece ANKARA ya ait olan malzemeleri değil diğer illere ait malzemeleri de getiriyor şöyle ki; ANKARA yı seçtim Tüm illerde yer alan MOUSE genel toplamı geldi. Oysa ki sadece o ile ait malzemelerin gelmesi ve onların toplamı gelmesi gerekiyor.

 

[YUSUF44]

Günaydın.

Evet nedenini bilemedim ama öyle oluyor maalesef. Düzeltmek için Listbox1 Change kodlarını aşağıdakilerle değiştirin (Kulağı biraz tersten göstermek gibi oldu ama elimden bu geliyor :

Private Sub ListBox1_Change()
If ListBox1.Visible = True Then
    [A1] = ListBox1.Value
    eski = WorksheetFunction.Max(4, Cells(Rows.Count, "A").End(3).Row)
    Range("A4:BM" & eski).ClearContents
    Set con = VBA.CreateObject("adodb.Connection")
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

    sorgu = "select distinct [MALZEME ADI] from[KAYIT$A1:I" & son & "] where [İL]='" & [A1].Value & " '"
    Set rs = con.Execute(sorgu)
    [A4].CopyFromRecordset rs
    Application.ScreenUpdating = False
        Set s1 = Sheets("KAYIT")
        veri = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "C").End(3).Row)
        sonurun = WorksheetFunction.Max(4, Cells(Rows.Count, "A").End(3).Row)
        sonsut = Cells(2, Columns.Count).End(xlToLeft).Column
        [B4].FormulaR1C1 = _
            "=SUMPRODUCT((KAYIT!R2C3:R" & veri & "C3=R1C1)*(YEAR(KAYIT!R2C2:R" & veri & "C2)=YEAR(R2C))*(MONTH(KAYIT!R2C2:R" & veri & _
            "C2)=MONTH(R2C))*(KAYIT!R2C5:R" & veri & "C5=RC1)*KAYIT!R2C7:R" & veri & "C7)"
        [C4].FormulaR1C1 = _
            "=SUMPRODUCT((KAYIT!R2C3:R" & veri & "C3=R1C1)*(YEAR(KAYIT!R2C2:R" & veri & "C2)=YEAR(R2C[-1]))*(MONTH(KAYIT!R2C2:R" & veri & _
            "C2)=MONTH(R2C[-1]))*(KAYIT!R2C5:R" & veri & "C5=RC1)*KAYIT!R2C8:R" & veri & "C8)"
        [B4:C4].Copy Range(Cells(4, "B"), Cells(sonurun, sonsut + 1))
        Range(Cells(4, "B"), Cells(sonurun, sonsut)).Copy: Range(Cells(4, "B"), Cells(sonurun, sonsut)).PasteSpecial Paste:=xlPasteValues
        For Each hucre In Range(Cells(4, "B"), Cells(sonurun, sonsut))
            If hucre.Value = 0 Then hucre.ClearContents
        Next
        ListBox1.Visible = False
        [A4].Select
    Application.ScreenUpdating = True
End If
End Sub

 

[Ahmet Sami]

Estağfirullah Yusuf bey ne demek, neticede hiç bir zorunluluğunuz olmamasına rağmen bana yardım etmeye çalıştınız ve de ettiniz. Çok teşekkür ederim.

 

[YUSUF44]

Kodun son bölümünde sonsut +1 yapmayı unutmuşum. Son hali şöyledir:

Private Sub ListBox1_Change()
If ListBox1.Visible = True Then
    [A1] = ListBox1.Value
    eski = WorksheetFunction.Max(4, Cells(Rows.Count, "A").End(3).Row)
    Range("A4:BM" & eski).ClearContents
    Set con = VBA.CreateObject("adodb.Connection")
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

    sorgu = "select distinct [MALZEME ADI] from[KAYIT$A1:I" & son & "] where [İL]='" & [A1].Value & " '"
    Set rs = con.Execute(sorgu)
    [A4].CopyFromRecordset rs
    Application.ScreenUpdating = False
        Set s1 = Sheets("KAYIT")
        veri = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "C").End(3).Row)
        sonurun = WorksheetFunction.Max(4, Cells(Rows.Count, "A").End(3).Row)
        sonsut = Cells(2, Columns.Count).End(xlToLeft).Column
        [B4].FormulaR1C1 = _
            "=SUMPRODUCT((KAYIT!R2C3:R" & veri & "C3=R1C1)*(YEAR(KAYIT!R2C2:R" & veri & "C2)=YEAR(R2C))*(MONTH(KAYIT!R2C2:R" & veri & _
            "C2)=MONTH(R2C))*(KAYIT!R2C5:R" & veri & "C5=RC1)*KAYIT!R2C7:R" & veri & "C7)"
        [C4].FormulaR1C1 = _
            "=SUMPRODUCT((KAYIT!R2C3:R" & veri & "C3=R1C1)*(YEAR(KAYIT!R2C2:R" & veri & "C2)=YEAR(R2C[-1]))*(MONTH(KAYIT!R2C2:R" & veri & _
            "C2)=MONTH(R2C[-1]))*(KAYIT!R2C5:R" & veri & "C5=RC1)*KAYIT!R2C8:R" & veri & "C8)"
        [B4:C4].Copy Range(Cells(4, "B"), Cells(sonurun, sonsut + 1))
        Range(Cells(4, "B"), Cells(sonurun, sonsut + 1)).Copy: Range(Cells(4, "B"), Cells(sonurun, sonsut + 1)).PasteSpecial Paste:=xlPasteValues
        For Each hucre In Range(Cells(4, "B"), Cells(sonurun, sonsut + 1))
            If hucre.Value = 0 Then hucre.ClearContents
        Next
        ListBox1.Visible = False
        [A4].Select
    Application.ScreenUpdating = True
End If
End Sub

 

[Ahmet Sami]

Çok teşekkür ederim sağolun