• DİKKAT

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

Hücredeki sayıyı ayrıştırma

S

sahika51

Altın Üye
Katılım
28 Ekim 2006
Mesajlar
187
Excel Vers. ve Dili
2010-2019
Ustalar hayırlı günler, ekte verdiğim örnek dosyada her kişinin c5 hücresinde haftalık girdiği ders sayısı var. biz bunları maaş ve ücrete otomatik dağıtmak istiyoruz.
1- C5 Teki rakam 15 in üstünde veya eşitse, 15 i e5-ı5 arasına dağıtsın. Ancak
2- arkadaşın gelmediği gün veya olmadığı günü ben sildiğim de (Bu herhangi bir gün olabilir) yani e5 ve ı5 arasındaki değerlerden birini veya bir kaçını sildiğim de 15 kalan gün sayısına dağıtılsın.
3- c5 15 in altında ise kurallar e5 ı5 arası için aynı.
4- c5 teki değer 15 e eşit veya yüksekse e6-ı6 hücrelerine c5 teki rakamdan e5-ı5 hücrelerine dağıttığımız rakamların toplamından çıkarıp kalan değeri yaymak istiyoruz. Ancak
5- e5-ı5 arasında hangi günü veya günleri silmiş isek otomatik olarak e6-ı6 arasına denk gelen gün veya günler silinmeli. Kalan sayı 15 ten yukarıda ise diğer günlere dağıtılmalı.

Bunu makro olarak yazılabilirmi?
Şimdiden teşekkür ederim.
 

Ekli dosyalar

Son düzenleme:
Zor bir soruydu belki belkide yapılamaz bir şeydi. Belkide ben anlatamamışımdır.
 
Merhaba.

Ya şöyle olursa diye ilave talebiniz olmayacaksa; mevcut örnek belgenize göre bir öneride bulunmak istedim.

UYARILAR:
►Kod ilgili satırda A sütununaki hücreyi kullanmaktadır. Bu nedenle A sütununu boş bırakın.
►E:I sütunlarındaki değerlerin tümünü silmek için C sütunundaki sayısal veriyi silmeniz yeterli olur.

Aşağıdaki şekilde işlem yaparsanız istediğiniz sonuca ulaşılacaktır.
-- Alt taraftan Sayfa1'in adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
-- Açılan VBA ekranında sağdaki boş alana aşağıdaki kod'u yapıştırın.
.
Kod: 
[B]Private Sub Worksheet_Change(ByVal Target As Range)[/B]
If Target.Column < 3 Or Target.Column > 10 Then Exit Sub
If Target.Column = 3 And Int((Target.Row - 1) / 4) = (Target.Row - 1) / 4 And Cells(Target.Row, 3) = "" Then
    If Cells(Target.Row, 1) = "X" Then Exit Sub
        Cells(Target.Row, 1) = "X"
    Range(Cells(Target.Row, 5), Cells(Target.Row + 1, 9)) = "": Cells(Target.Row, 1) = "": Exit Sub
ElseIf Target.Column = 3 And Int((Target.Row - 1) / 4) = (Target.Row - 1) / 4 And Cells(Target.Row, 3) < 15 Then
    If Cells(Target.Row, 1) = "X" Then Exit Sub
        Cells(Target.Row, 1) = "X": Range(Cells(Target.Row + 1, 5), Cells(Target.Row + 1, 9)) = ""
    topl = Cells(Target.Row, 3): ustkisibasi = topl / 5
    Range(Cells(Target.Row, 5), Cells(Target.Row, 9)) = ustkisibasi: Cells(Target.Row, 1) = "": Exit Sub
ElseIf Target.Column = 3 And Int((Target.Row - 1) / 4) = (Target.Row - 1) / 4 Then
    If Target >= 15 Then
        Cells(Target.Row, 1) = "X": Range(Cells(Target.Row, 5), Cells(Target.Row, 9)) = 3: artan = Target - 15
        dolu = 5 - WorksheetFunction.CountBlank(Range(Cells(Target.Row, 5), Cells(Target.Row, 9)))
        artankisibasi = artan / dolu: ustkisibasi = 3
            For sut = 5 To 9
                If Cells(Target.Row, sut) > 0 Then Cells(Target.Row + 1, sut) = artankisibasi
            Next
        Cells(Target.Row, 1) = "": Exit Sub
    ElseIf Target < 15 Then
        topl = Cells(Target.Row, "X"): kisibasi = topl / 5
        Range(Cells(Target.Row + 1, 5), Cells(Target.Row + 1, 9)) = ""
        Range(Cells(Target.Row, 5), Cells(Target.Row, 9)) = kisibasi
    End If
ElseIf Target.Column > 4 And Target.Column < 10 And Int((Target.Row - 1) / 4) = (Target.Row - 1) / 4 Then
    If Cells(Target.Row, 1) = "X" Then Exit Sub
        Cells(Target.Row, 1) = "X"
            If Target = "" Then Cells(Target.Row + 1, Target.Column) = ""
        topl = Cells(Target.Row, 3)
            If topl >= 15 Then
                For sut = 5 To 9
                    dolu = 5 - WorksheetFunction.CountBlank(Range(Cells(Target.Row, 5), Cells(Target.Row, 9)))
                    artan = topl - 15: ustkisibasi = 15 / dolu: artankisibasi = artan / dolu
                    If Cells(Target.Row, sut) > 0 Then Cells(Target.Row, sut) = ustkisibasi
                    If Cells(Target.Row, sut) > 0 Then Cells(Target.Row + 1, sut) = artankisibasi
                Next
                Cells(Target.Row, 1) = "": Exit Sub
            End If
End If
[B]End Sub[/B]
 
Ömer Bey Teşekkür Ederim. Süpersiniz. İlave talep uyarınıza rağmen, Son bir kez rakamları dağıttığımızda ramaklar tam sayı olmalı. Örnek c ye 17 verelim ve bir herhangi bir günü örnek salı günü boş olsun. M satırı 3,75 Ü satırı 0,5 şeklinde doluyor. Bunları tam sayı dağıtamazmı.
 
İlave talep geleceğini tahmin ettiğimden o şekilde yazmıştım.
Önce belge tasarımı ve iş akışının kafada netleşmesi gerekir, bu kısım tamam olduğunda mutlaka bir çözüm bulunur.

Bir örnekle netleştirelim:
► Önce C9'a 20 yazdınız.
-- E9:I9 arasına 3'erden toplam 15 dağıtıldı,
-- alt satıra ise geriye kalan 5 (20-15) sayıısı 1'er şeklinde dağıtıldı.
► Sonra G9'daki 3 sayısını sildiniz.
-- bu durumda silinen 3 sayısının E9, F9, H9 ve I9'a dağıtılması gerekmiyor mu?
-- G9 silindiğinde otomatik silinen G10'daki 1 sayısının da E10, F10, H10 ve I10'a dağıtılması gerekmiyor mu?

► İşlem akışı 1) C sütununa sayı yaz dağıtımı yap, 2) dağıtımı yapılan değerlerden üst satırdaki birini sil, daha sonra gerekli ise üst satırdan birini daha sil .... şeklinde,
silme işleminden sonra tekrar C sütununa bir sayı yazarsanız iş akışı başa döner ve tüm sütunlara dağıtılır.

► Başlangıçtaki isteğiniz:
-- hangi işlemi (yazma/silme) yaparsanız yapın, E9:I10 arası toplamının C9'a eşit olmasını siz istiyorsunuz.
-- (C9-15) / 5 işlemi sonucunun her zaman TAMSAYI OLMAYACAĞInı zaten öngörmediniz mi?
 
Haklısınız ömer bey, Elinize sağlık. Uğraşmışınız. Ben Soruyu yazarken eksik, öngöremediğim veya mantığını doğru açıklayamadığım yerler var.
1- C9 hücresine 15ten aşağı sayıların yazılma ihtimali de var. Örneğin 13 olabilir. 13 sayısı e9-ı9 arasına dağıtılırken tam sayı olmalı. Örnek 3 3 3 2 2 gibi. veya bir hücreyi silersem 43 33 gibi dağıtmalı

2- c9 hücresine örneğin 20 yazarsam ve g9 hücresini silersem 20 sayısını 4 güne bölüp e9-ı9 örneğin 4 4 4 3 gibi yayabilir e10-ı10 arasını da 2 1 1 1 şeklinde olabilir.
 
Tekrar merhaba.

Son yazdıklarınız tamamen yeni bir durum ve kodlamanın baştan ele alınmasını gerektirir ve malesef
önceki emeğin boşa gitmesi anlamına geliyor.

Umarım kodları, VBA ekranını açıp doğrudan yazdığımızı düşünmüyorsunuz.

Kod yazma işlemi; netice itibariyle adım adım ilerleyerek / denemeler yaparak / muhtemel uç durumlara ilişkin
önlemler-sınırlamalar eklenmesi/silinmesi gibi aşamaları olan biraz zahmetli / sabır isteyen bir iş.

Uygun olduğumda, zihnim berrak iken tekrar bakmaya çalışırım ancak yine cevap yazdığımda bu kez de;
başlangıç sütunu değişti/sağa doğru şu sütun gruplarında da aynı uygulama olsun/tablonun
başlangıç satırı değişti gibi kod'un revize edilmesi talebinin geleceğine kesin gözüyle bakıyorum doğrusu.

Bence ilk iş olarak; gerçek belgenizin özel bilgi içermeyen bir kopyasını ekleyin ki en azından uğraşıldığına değsin, değil mi?.
.
 
Aşağıdaki kod istenilen işlemi yapacaktır.
Önceki cevabımda da belirttiğim gibi; kod, ilgili sütunda A sütununu kullanmaktadır.
Bu nedenle A sütununda veri bulundurmayınız.
.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < 3 Or Target.Column > 10 Then Exit Sub
Set wf = Application.WorksheetFunction
If Target.Column = 3 And _
    Int((Target.Row - 1) / 4) = (Target.Row - 1) / 4 Then
    If Cells(Target.Row, 3) = "" Then
        Range("E" & Target.Row & ":I" & Target.Row + 1).ClearContents
        Exit Sub
    ElseIf Cells(Target.Row, 3) < 15 Then
        Cells(Target.Row, "A") = "X"
        Range("E" & Target.Row & ":I" & Target.Row + 1).ClearContents
        artan = Cells(Target.Row, 3) - Int(Cells(Target.Row, 3) / 5) * 5
        Range("E" & Target.Row & ":I" & Target.Row) = Int(Cells(Target.Row, 3) / 5)
            For sut = 5 To 4 + artan
                Cells(Target.Row, sut) = Cells(Target.Row, sut) + 1
            Next
        Cells(Target.Row, "A") = ""
    ElseIf Cells(Target.Row, 3) >= 15 Then
        Cells(Target.Row, "A") = "X"
        Range("E" & Target.Row & ":I" & Target.Row + 1).ClearContents
        tam = 3
        artan = Cells(Target.Row, 3) - tam * 5
        Range("E" & Target.Row & ":I" & Target.Row) = tam
                Range("E" & Target.Row + 1 & ":I" & Target.Row + 1) = Int(artan / 5)
                kalan = artan - Int(artan / 5) * 5
            For sut = 5 To 4 + kalan
                Cells(Target.Row + 1, sut) = Cells(Target.Row + 1, sut) + 1
            Next
        Cells(Target.Row, "A") = ""
    End If
ElseIf Target.Column > 4 And Target.Column < 10 And _
    Int((Target.Row - 1) / 4) = (Target.Row - 1) / 4 Then
    If Cells(Target.Row, 1) = "X" Then GoTo 10
    If wf.CountBlank(Range("E" & Target.Row & ":I" & Target.Row)) = 5 And _
        Cells(Target.Row, "C") <> "" Then
       Range("E" & Target.Row + 1 & ":I" & Target.Row + 1).ClearContents
        MsgBox "Üst satırda tüm değerleri sildiniz." & vbLf & _
            "C" & Target.Row & " hücresindeki değeri tekrar yazınız.", vbCritical
            Range("C" & Target.Row) = ""
        Exit Sub
    End If
On Error Resume Next
    If Target = "" Then
        althedef = wf.Sum(Range("E" & Target.Row + 1 & ":I" & Target.Row + 1))
        Cells(Target.Row + 1, Target.Column).ClearContents
        usthedef = wf.Min(Cells(Target.Row, "C"), 15)
        bosluk = wf.CountBlank(Range("E" & Target.Row & ":I" & Target.Row))
        For sut = 5 To 9
            If Cells(Target.Row, sut) <> "" Then _
                Cells(Target.Row, sut) = Int(usthedef / (5 - bosluk))
            If Cells(Target.Row + 1, sut) <> "" Then _
            Cells(Target.Row + 1, sut) = Int(althedef / (5 - bosluk))
        Next
        For s = 5 To 9
            If Cells(Target.Row, s) <> "" And _
                wf.Sum(Range("E" & Target.Row & ":I" & Target.Row)) < usthedef Then
                Cells(Target.Row, s) = Cells(Target.Row, s) + 1
            End If
            If Cells(Target.Row + 1, s) <> "" And _
                wf.Sum(Range("E" & Target.Row + 1 & ":I" & Target.Row + 1)) < althedef Then
                Cells(Target.Row + 1, s) = Cells(Target.Row + 1, s) + 1
            End If
        Next
10: End If
End If
[B]End Sub[/B]
 
Ömer bey tam istediğm gibi elinize sağlık. Çok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst