Ödemeleri sayfalara dağıtmak ?

[mecnun24_]

Merhabalar. Acizane bir cari hesap tasarımım var. Bir özellik eklemek istiyorum. Başka bir çalışma kitabından verileri hazır olarak talimat sayfasına yapıştırıyorum. Dağıt tuşuna basıp ödemeleri sayfalara dağıtmaya çalışıyorum. İşlemin giriş kodlarını yazdım, tarih kontrolü yapıyor. sonra işlem daha önce yapılmışmı kontrolünü yapıyor. İşlemi yapılmayan bir kayıta geldiğinde döngüye giriyor. Yazmak istediğim kod burda başlıyor. Örneğin b71 hücresini ele alalım 470,00 tl ödemeyi Ferhat Maden sayfasına yazdırmaya çalışıyorum. 470,00 tl'nin iki sütun yanındaki açıklamanın ilk iki kelimesini alsın döngüye girsin tüm sayfaların a4 hücresiyle karşılaştırsın bir denklik bulursa o sayfanın ilk satırına tutarı yazsın. işleme alındığını göstermek için 470 tl nin bir sütun yanına 1 yazsın. döngüden çıksın sonra alttaki tutardan 165,27 devam etsin. Umarım anlatabilmişimdir. En azından bir fikir verirseniz sevinirim. son döngüde takıldım kaldım. Yardımlarınızı bekliyorum..saygılar

 

[Ömer]

Merhaba,

Bu şekilde deneyiniz.

On Error Resume Next
For i = 71 To [D65536].End(3).Row
    If Cells(i, "C") = "" Then
        Veri = UCase(Replace(Replace(Split(Cells(i, "D"), " ")(0) & " " & _
        Split(Cells(i, "D"), " ")(1), "i", "İ"), "ı", "I"))
        For Each sayfa In Worksheets
            Ara = UCase(Replace(Replace(sayfa.Range("A4"), "i", "İ"), "ı", "I"))
            son = sayfa.[A65536].End(3).Row + 1
            If Ara = Veri Then
                sayfa.Range("A" & son) = Range("B70")[COLOR=green] ' Tarih[/COLOR]
                sayfa.Range("[COLOR=black]D[/COLOR]" & son) = Cells(i, "B") [COLOR=green]' Tutar[/COLOR]
                Cells(i, "C") = Cells(i, "C") + 1[COLOR=green] 'Eşleşeni Say[/COLOR]
            End If
        Next sayfa
    End If
Next i

.

 

[mecnun24_]

tşkrler ellerinize sağlık. çok güzel olmuş. affınıza sığınarak bir şey daha isteyeceğim. Bazan isim benzerlikleri olabiliyor eğer işlemi benzerlikten dolayı iki ayrı sayfaya yazarsa anlamak adına işlem bittikten sonra c sütununa 1 değilde işlediği sayfa kadar yazı yazdırabilirmiyiz. tşkrler.

- Ömer bey şimdi farkettim tuşa bastıkça kayıtları mükerrer giriyor. C sütununu ben onu düşünerek ayırmıştım aslında C sütununda sıfırdan büyük bir değer varsa işlendiğini anlayıp tekrar işlem yapmasın. Ama şimdi ilk önce c sütununu temizlediği için her seferinde kayıtları tekrar tekrar giriyor.

 

[Ömer]

#2 nolu mesajı değiştirdim, tekrar denermisiniz..

.

 

[mecnun24_]

Çok teşekkürler Ömer Bey. çok güzel olmuş elinize sağlık. Birkaç bişey var onları da kendim yapmaya çalışacağım yapamazsam yardımınızı isterim.tşkler

 

[Ömer]

Rica ederim, iyi çalışmalar.

 

[mecnun24_]

Ömer Bey kodunuzu şu an kullanmakta olduğum cari hesap sayfalarına uygaladım ama çalıştıramadım. Çalışma kitabının bir özelliğinden dolayı çalışmıyor olabilirmi acaba çözemedim. Bir örnek yüklüyorum bakarsanız sevinirim.

 

[Ömer]

Dosyanız şifreli kalmış.

.

 

[mecnun24_]

Kusura bakmayın. şifre "3+3+3+"

 

[Ömer]

Sayfalar A4 deki veri düzenini değiştirmişsiniz.

Bu şekilde deneyiniz..

On Error Resume Next
For i = 71 To [D65536].End(3).Row
    If Cells(i, "C") = "" Then
        Veri = UCase(Replace(Replace(Split(Cells(i, "D"), " ")(0) & " " & _
        Split(Cells(i, "D"), " ")(1), "i", "İ"), "ı", "I"))
        For Each sayfa In Worksheets
            Ara = UCase(Replace(Replace(sayfa.Range("A4"), "i", "İ"), "ı", "I"))
            Bul = Split(Ara, " ")(0) & " " & Split(Ara, " ")(1)
            son = sayfa.[A65536].End(3).Row + 1
            If Bul = Veri Then
                sayfa.Range("A" & son) = Range("B70") ' Tarih
                sayfa.Range("D" & son) = Cells(i, "B") ' Tutar
                Cells(i, "C") = Cells(i, "C") + 1 'Eşleşeni Say
            End If
        Next sayfa
    End If
Next i

.

 

[assenucler]

Bir rica.

Sayın mecnun24;

Merhaba...

Bu güzel çalışmanız için tebrikler..

Sayın Ömer hoca'nın kodunu nereye ekleyeceğimi saptayamadım.

Dosyanın son halini ekleyebilir misiniz?

Emeğiniz için size ve katkılarından dolayı da hocama teşekkürler...

 

[Ömer]

Dosyada Talimat sayfasına gelin sayfa adı üzerine sağ kilik yapın ve kod görüntüle seçeneğiyle kod ekranına girin bu ekrandaki,

Eski Private Sub CommandButton3_Click() bağlı kodları silerek yerine aşağıdaki kodları yazmanız yeterli olacaktır..

Private Sub CommandButton3_Click()
On Error Resume Next
For i = 71 To [D65536].End(3).Row
    If Cells(i, "C") = "" Then
        Veri = UCase(Replace(Replace(Split(Cells(i, "D"), " ")(0) & " " & _
        Split(Cells(i, "D"), " ")(1), "i", "İ"), "ı", "I"))
        For Each sayfa In Worksheets
            Ara = UCase(Replace(Replace(sayfa.Range("A4"), "i", "İ"), "ı", "I"))
            Bul = Split(Ara, " ")(0) & " " & Split(Ara, " ")(1)
            son = sayfa.[A65536].End(3).Row + 1
            If Bul = Veri Then
                sayfa.Range("A" & son) = Range("B70") ' Tarih
                sayfa.Range("D" & son) = Cells(i, "B") ' Tutar
                Cells(i, "C") = Cells(i, "C") + 1 'Eşleşeni Say
            End If
        Next sayfa
    End If
Next i
End Sub

.

 

[assenucler]

Sayın Ömer;

Hocam inceliğiniz ve yanıtınız için teşekkürler..

Sevgi ve saygılar..

 

[mecnun24_]

Ömer bey iyi günler. Yazdığınız kod para birimi kontrolü de ekledikten sonra mükemmel oldu tşkler. sizden başka bir çalışma sayfası hakkında yardım istiyorum. Ekteki dosyada a,b,c,d kolanlarını hazır olarak kopyalıyorum. Düzen tuşuyla para birimlerini ekliyorum ve boşlukları siliyorum.. son adımda takıldım. istediğim d sütununda "mermer eft" kelimeleri geçiyorsa o satırı KESİP (4 sütun olarak) e sütunundan başlayan bölüme yapıştırması. "korteks eft" kelimeleri geçiyorsa ı sütunundan başlayan bölüme, "hinen eft" kelimeleri geçiyorsada m sütunundan başlayan bölüme yapıştırması. Yani kısaca firmalara göre tasnif etmesi.tşkrler.
syn assenucler yeni gördüm ama Ömer hocam açıklamış zaten.

 

[Ömer]

Bu şekilde deneyiniz.

Sub Duzenle()
Application.ScreenUpdating = False
Range("E2:Q65536").ClearContents
For j = 4 To Cells(1, Columns.Count).End(xlToLeft).Column
    Bak = UCase(Replace(Replace(Cells(1, j), "i", "İ"), "ı", "I"))
    sat = 1
    If j Mod 4 = 1 Then
        For i = 1 To Cells(Rows.Count, "D").End(xlUp).Row
        Ara = UCase(Replace(Replace(Cells(i, "D"), "i", "İ"), "ı", "I"))
           If Ara Like "*" & Bak & "*" Then
                sat = sat + 1
                Range("A" & i & ":D" & i).Copy Cells(sat, j)
            End If
        Next i
    End If
Next j
Application.ScreenUpdating = True
End Sub

Eğer veriler silinecekse;

Sub Duzenle()
Application.ScreenUpdating = False
For j = 4 To Cells(1, Columns.Count).End(xlToLeft).Column
    Bak = UCase(Replace(Replace(Cells(1, j), "i", "İ"), "ı", "I"))
    sat = 1
    If j Mod 4 = 1 Then
        For i = 1 To Cells(Rows.Count, "D").End(xlUp).Row
        Ara = UCase(Replace(Replace(Cells(i, "D"), "i", "İ"), "ı", "I"))
           If Ara Like "*" & Bak & "*" Then
                sat = sat + 1
                Range("A" & i & ":D" & i).Cut Cells(sat, j)
            End If
        Next i
    End If
Next j
Columns("A:D").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub

Not : Farklı konularla ilgili sorularınız için yeni konu başlığı açarak sorunuzu sormanızı rica ederim.

.

 

[mecnun24_]

Tşkrler elinize sağlık